{-|
Helpers for beancount output.
-}

{-# LANGUAGE OverloadedStrings    #-}

module Hledger.Write.Beancount (
  showTransactionBeancount,
  -- postingsAsLinesBeancount,
  -- postingAsLinesBeancount,
  -- showAccountNameBeancount,
  tagsToBeancountMetadata,
  showBeancountMetadata,
  accountNameToBeancount,
  commodityToBeancount,
  -- 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.Printf
import Text.Tabular.AsciiWide hiding (render)

import Hledger.Utils
import Hledger.Data.Types
import Hledger.Data.AccountName
import Hledger.Data.Amount
import Hledger.Data.Currency (currencySymbolToCode)
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
-- >>> :set -XOverloadedStrings

-- | Like showTransaction, but applies various adjustments to produce valid Beancount journal data.
showTransactionBeancount :: Transaction -> Text
showTransactionBeancount :: Transaction -> BeancountCommoditySymbol
showTransactionBeancount Transaction
t =
  -- https://beancount.github.io/docs/beancount_language_syntax.html
  -- similar to showTransactionHelper, but I haven't bothered with Builder
     BeancountCommoditySymbol
firstline BeancountCommoditySymbol
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a. Semigroup a => a -> a -> a
<> BeancountCommoditySymbol
nl
  BeancountCommoditySymbol
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a. Semigroup a => a -> a -> a
<> ((BeancountCommoditySymbol, BeancountCommoditySymbol)
 -> BeancountCommoditySymbol)
-> [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
-> BeancountCommoditySymbol
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((BeancountCommoditySymbol
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a. Semigroup a => a -> a -> a
<> BeancountCommoditySymbol
nl)(BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> ((BeancountCommoditySymbol, BeancountCommoditySymbol)
    -> BeancountCommoditySymbol)
-> (BeancountCommoditySymbol, BeancountCommoditySymbol)
-> BeancountCommoditySymbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
.BeancountCommoditySymbol -> BeancountCommoditySymbol
postingIndent(BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> ((BeancountCommoditySymbol, BeancountCommoditySymbol)
    -> BeancountCommoditySymbol)
-> (BeancountCommoditySymbol, BeancountCommoditySymbol)
-> BeancountCommoditySymbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Maybe Int
-> (BeancountCommoditySymbol, BeancountCommoditySymbol)
-> BeancountCommoditySymbol
showBeancountMetadata (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
maxmdnamewidth)) [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
mds
  BeancountCommoditySymbol
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a. Semigroup a => a -> a -> a
<> (BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> [BeancountCommoditySymbol] -> BeancountCommoditySymbol
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((BeancountCommoditySymbol
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a. Semigroup a => a -> a -> a
<> BeancountCommoditySymbol
nl)) [BeancountCommoditySymbol]
newlinecomments
  BeancountCommoditySymbol
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a. Semigroup a => a -> a -> a
<> (BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> [BeancountCommoditySymbol] -> BeancountCommoditySymbol
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((BeancountCommoditySymbol
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a. Semigroup a => a -> a -> a
<> BeancountCommoditySymbol
nl)) ([Posting] -> [BeancountCommoditySymbol]
postingsAsLinesBeancount ([Posting] -> [BeancountCommoditySymbol])
-> [Posting] -> [BeancountCommoditySymbol]
forall a b. (a -> b) -> a -> b
$ Transaction -> [Posting]
tpostings Transaction
t)
  BeancountCommoditySymbol
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a. Semigroup a => a -> a -> a
<> BeancountCommoditySymbol
nl
  where
    firstline :: BeancountCommoditySymbol
firstline = [BeancountCommoditySymbol] -> BeancountCommoditySymbol
T.concat [BeancountCommoditySymbol
date, BeancountCommoditySymbol
status, BeancountCommoditySymbol
payee, BeancountCommoditySymbol
note, BeancountCommoditySymbol
samelinecomment]
    date :: BeancountCommoditySymbol
date = Day -> BeancountCommoditySymbol
showDate (Day -> BeancountCommoditySymbol)
-> Day -> BeancountCommoditySymbol
forall a b. (a -> b) -> a -> b
$ Transaction -> Day
tdate Transaction
t
    status :: BeancountCommoditySymbol
status = if Transaction -> Status
tstatus Transaction
t Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
Pending then BeancountCommoditySymbol
" !" else BeancountCommoditySymbol
" *"
    (BeancountCommoditySymbol
payee,BeancountCommoditySymbol
note) =
      case BeancountCommoditySymbol
-> (BeancountCommoditySymbol, BeancountCommoditySymbol)
payeeAndNoteFromDescription' (BeancountCommoditySymbol
 -> (BeancountCommoditySymbol, BeancountCommoditySymbol))
-> BeancountCommoditySymbol
-> (BeancountCommoditySymbol, BeancountCommoditySymbol)
forall a b. (a -> b) -> a -> b
$ Transaction -> BeancountCommoditySymbol
tdescription Transaction
t of
        (BeancountCommoditySymbol
"",BeancountCommoditySymbol
"") -> (BeancountCommoditySymbol
"",      BeancountCommoditySymbol
""      )
        (BeancountCommoditySymbol
"",BeancountCommoditySymbol
n ) -> (BeancountCommoditySymbol
""     , BeancountCommoditySymbol -> BeancountCommoditySymbol
wrapq BeancountCommoditySymbol
n )
        (BeancountCommoditySymbol
p ,BeancountCommoditySymbol
"") -> (BeancountCommoditySymbol -> BeancountCommoditySymbol
wrapq BeancountCommoditySymbol
p, BeancountCommoditySymbol -> BeancountCommoditySymbol
wrapq BeancountCommoditySymbol
"")
        (BeancountCommoditySymbol
p ,BeancountCommoditySymbol
n ) -> (BeancountCommoditySymbol -> BeancountCommoditySymbol
wrapq BeancountCommoditySymbol
p, BeancountCommoditySymbol -> BeancountCommoditySymbol
wrapq BeancountCommoditySymbol
n )
      where
        wrapq :: BeancountCommoditySymbol -> BeancountCommoditySymbol
wrapq = BeancountCommoditySymbol
-> BeancountCommoditySymbol
-> BeancountCommoditySymbol
-> BeancountCommoditySymbol
wrap BeancountCommoditySymbol
" \"" BeancountCommoditySymbol
"\"" (BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> (BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> BeancountCommoditySymbol
-> BeancountCommoditySymbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BeancountCommoditySymbol -> BeancountCommoditySymbol
escapeDoubleQuotes (BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> (BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> BeancountCommoditySymbol
-> BeancountCommoditySymbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BeancountCommoditySymbol -> BeancountCommoditySymbol
escapeBackslash
    mds :: [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
mds = [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
-> [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
tagsToBeancountMetadata ([(BeancountCommoditySymbol, BeancountCommoditySymbol)]
 -> [(BeancountCommoditySymbol, BeancountCommoditySymbol)])
-> [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
-> [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
forall a b. (a -> b) -> a -> b
$ Transaction
-> [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
ttags Transaction
t
    maxmdnamewidth :: Int
maxmdnamewidth = [Int] -> Int
forall a. Integral a => [a] -> a
maximum' ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ ((BeancountCommoditySymbol, BeancountCommoditySymbol) -> Int)
-> [(BeancountCommoditySymbol, BeancountCommoditySymbol)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (BeancountCommoditySymbol -> Int
T.length (BeancountCommoditySymbol -> Int)
-> ((BeancountCommoditySymbol, BeancountCommoditySymbol)
    -> BeancountCommoditySymbol)
-> (BeancountCommoditySymbol, BeancountCommoditySymbol)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BeancountCommoditySymbol, BeancountCommoditySymbol)
-> BeancountCommoditySymbol
forall a b. (a, b) -> a
fst) [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
mds
    (BeancountCommoditySymbol
samelinecomment, [BeancountCommoditySymbol]
newlinecomments) =
      case BeancountCommoditySymbol -> [BeancountCommoditySymbol]
renderCommentLines (Transaction -> BeancountCommoditySymbol
tcomment Transaction
t) of []   -> (BeancountCommoditySymbol
"",[])
                                              BeancountCommoditySymbol
c:[BeancountCommoditySymbol]
cs -> (BeancountCommoditySymbol
c,[BeancountCommoditySymbol]
cs)

nl :: BeancountCommoditySymbol
nl = BeancountCommoditySymbol
"\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 :: Maybe Int
-> (BeancountCommoditySymbol, BeancountCommoditySymbol)
-> BeancountCommoditySymbol
showBeancountMetadata Maybe Int
mmaxnamewidth (BeancountCommoditySymbol
n,BeancountCommoditySymbol
v) =
  Maybe Int
-> Maybe Int
-> Bool
-> Bool
-> BeancountCommoditySymbol
-> BeancountCommoditySymbol
fitText ((Int -> Int) -> Maybe Int -> Maybe Int
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2) Maybe Int
mmaxnamewidth) Maybe Int
forall a. Maybe a
Nothing Bool
False Bool
True (BeancountCommoditySymbol
n BeancountCommoditySymbol
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a. Semigroup a => a -> a -> a
<> BeancountCommoditySymbol
": ")
  BeancountCommoditySymbol
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a. Semigroup a => a -> a -> a
<> BeancountCommoditySymbol -> BeancountCommoditySymbol
toBeancountMetadataValue BeancountCommoditySymbol
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 :: [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
-> [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
tagsToBeancountMetadata = [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
-> [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
forall a. Ord a => [a] -> [a]
sort ([(BeancountCommoditySymbol, BeancountCommoditySymbol)]
 -> [(BeancountCommoditySymbol, BeancountCommoditySymbol)])
-> ([(BeancountCommoditySymbol, BeancountCommoditySymbol)]
    -> [(BeancountCommoditySymbol, BeancountCommoditySymbol)])
-> [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
-> [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((BeancountCommoditySymbol, BeancountCommoditySymbol)
 -> (BeancountCommoditySymbol, BeancountCommoditySymbol))
-> [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
-> [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
forall a b. (a -> b) -> [a] -> [b]
map ((BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> (BeancountCommoditySymbol, BeancountCommoditySymbol)
-> (BeancountCommoditySymbol, BeancountCommoditySymbol)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first BeancountCommoditySymbol -> BeancountCommoditySymbol
toBeancountMetadataName) ([(BeancountCommoditySymbol, BeancountCommoditySymbol)]
 -> [(BeancountCommoditySymbol, BeancountCommoditySymbol)])
-> ([(BeancountCommoditySymbol, BeancountCommoditySymbol)]
    -> [(BeancountCommoditySymbol, BeancountCommoditySymbol)])
-> [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
-> [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
-> [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
uniquifyTags ([(BeancountCommoditySymbol, BeancountCommoditySymbol)]
 -> [(BeancountCommoditySymbol, BeancountCommoditySymbol)])
-> ([(BeancountCommoditySymbol, BeancountCommoditySymbol)]
    -> [(BeancountCommoditySymbol, BeancountCommoditySymbol)])
-> [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
-> [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((BeancountCommoditySymbol, BeancountCommoditySymbol) -> Bool)
-> [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
-> [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not(Bool -> Bool)
-> ((BeancountCommoditySymbol, BeancountCommoditySymbol) -> Bool)
-> (BeancountCommoditySymbol, BeancountCommoditySymbol)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.BeancountCommoditySymbol -> Bool
isHiddenTagName(BeancountCommoditySymbol -> Bool)
-> ((BeancountCommoditySymbol, BeancountCommoditySymbol)
    -> BeancountCommoditySymbol)
-> (BeancountCommoditySymbol, BeancountCommoditySymbol)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(BeancountCommoditySymbol, BeancountCommoditySymbol)
-> BeancountCommoditySymbol
forall a b. (a, b) -> a
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 :: [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
-> [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
uniquifyTags [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
ts = [(BeancountCommoditySymbol
k, BeancountCommoditySymbol
-> [BeancountCommoditySymbol] -> BeancountCommoditySymbol
T.intercalate BeancountCommoditySymbol
", " ([BeancountCommoditySymbol] -> BeancountCommoditySymbol)
-> [BeancountCommoditySymbol] -> BeancountCommoditySymbol
forall a b. (a -> b) -> a -> b
$ ((BeancountCommoditySymbol, BeancountCommoditySymbol)
 -> BeancountCommoditySymbol)
-> [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
-> [BeancountCommoditySymbol]
forall a b. (a -> b) -> [a] -> [b]
map (BeancountCommoditySymbol, BeancountCommoditySymbol)
-> BeancountCommoditySymbol
forall a b. (a, b) -> b
snd ([(BeancountCommoditySymbol, BeancountCommoditySymbol)]
 -> [BeancountCommoditySymbol])
-> [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
-> [BeancountCommoditySymbol]
forall a b. (a -> b) -> a -> b
$ [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
tags) | (BeancountCommoditySymbol
k, [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
tags) <- ((BeancountCommoditySymbol, BeancountCommoditySymbol)
 -> BeancountCommoditySymbol)
-> [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
-> [(BeancountCommoditySymbol,
     [(BeancountCommoditySymbol, BeancountCommoditySymbol)])]
forall k a. Eq k => (a -> k) -> [a] -> [(k, [a])]
groupOnKey (BeancountCommoditySymbol, BeancountCommoditySymbol)
-> BeancountCommoditySymbol
forall a b. (a, b) -> a
fst ([(BeancountCommoditySymbol, BeancountCommoditySymbol)]
 -> [(BeancountCommoditySymbol,
      [(BeancountCommoditySymbol, BeancountCommoditySymbol)])])
-> [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
-> [(BeancountCommoditySymbol,
     [(BeancountCommoditySymbol, BeancountCommoditySymbol)])]
forall a b. (a -> b) -> a -> b
$ [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
-> [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
forall a. Ord a => [a] -> [a]
sort [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
ts]

toBeancountMetadataName :: TagName -> Text
toBeancountMetadataName :: BeancountCommoditySymbol -> BeancountCommoditySymbol
toBeancountMetadataName BeancountCommoditySymbol
name =
  BeancountCommoditySymbol -> BeancountCommoditySymbol
prependStartCharIfNeeded (BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a b. (a -> b) -> a -> b
$
  case BeancountCommoditySymbol -> Maybe (Char, BeancountCommoditySymbol)
T.uncons BeancountCommoditySymbol
name of
    Maybe (Char, BeancountCommoditySymbol)
Nothing -> BeancountCommoditySymbol
""
    Just (Char
c,BeancountCommoditySymbol
cs) ->
      (Char -> BeancountCommoditySymbol)
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
T.concatMap (\Char
d -> if Char -> Bool
isBeancountMetadataNameChar Char
d then Char -> BeancountCommoditySymbol
T.singleton Char
d else Char -> BeancountCommoditySymbol
toBeancountMetadataNameChar Char
d) (BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a b. (a -> b) -> a -> b
$ Char -> BeancountCommoditySymbol -> BeancountCommoditySymbol
T.cons Char
c BeancountCommoditySymbol
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 :: BeancountCommoditySymbol -> BeancountCommoditySymbol
prependStartCharIfNeeded BeancountCommoditySymbol
t =
      case BeancountCommoditySymbol -> Maybe (Char, BeancountCommoditySymbol)
T.uncons BeancountCommoditySymbol
t of
        Maybe (Char, BeancountCommoditySymbol)
Nothing -> Int -> BeancountCommoditySymbol -> BeancountCommoditySymbol
T.replicate Int
2 (BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a b. (a -> b) -> a -> b
$ Char -> BeancountCommoditySymbol
T.singleton Char
beancountMetadataDummyNameStartChar
        Just (Char
c,BeancountCommoditySymbol
cs) | BeancountCommoditySymbol -> Bool
T.null BeancountCommoditySymbol
cs Bool -> Bool -> Bool
|| Bool -> Bool
not (Char -> Bool
isBeancountMetadataNameStartChar Char
c) -> Char -> BeancountCommoditySymbol -> BeancountCommoditySymbol
T.cons Char
beancountMetadataDummyNameStartChar BeancountCommoditySymbol
t
        Maybe (Char, BeancountCommoditySymbol)
_ -> BeancountCommoditySymbol
t

-- | Is this a valid character to start a Beancount metadata name (lowercase letter) ?
isBeancountMetadataNameStartChar :: Char -> Bool
isBeancountMetadataNameStartChar :: Char -> Bool
isBeancountMetadataNameStartChar Char
c = Char -> Bool
isLetter Char
c Bool -> Bool -> Bool
&& Char -> Bool
islowercase Char
c

-- | Dummy valid starting character to prepend to a Beancount metadata name if needed.
beancountMetadataDummyNameStartChar :: Char
beancountMetadataDummyNameStartChar :: Char
beancountMetadataDummyNameStartChar = Char
'm'

-- | Is this a valid character in the middle of a Beancount metadata name (a lowercase letter, digit, _ or -) ?
isBeancountMetadataNameChar :: Char -> Bool
isBeancountMetadataNameChar :: Char -> Bool
isBeancountMetadataNameChar Char
c = (Char -> Bool
isLetter Char
c Bool -> Bool -> Bool
&& Char -> Bool
islowercase Char
c) Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'_', Char
'-']

-- | 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 :: Char -> BeancountCommoditySymbol
toBeancountMetadataNameChar Char
c
  | Char -> Bool
isBeancountMetadataNameChar Char
c = Char -> BeancountCommoditySymbol
T.singleton Char
c
  | Char -> Bool
isLetter Char
c = Char -> BeancountCommoditySymbol
T.singleton (Char -> BeancountCommoditySymbol)
-> Char -> BeancountCommoditySymbol
forall a b. (a -> b) -> a -> b
$ Char -> Char
toLower Char
c
  | Char -> Bool
isSpace Char
c = BeancountCommoditySymbol
"-"
  | Bool
otherwise = String -> BeancountCommoditySymbol
T.pack (String -> BeancountCommoditySymbol)
-> String -> BeancountCommoditySymbol
forall a b. (a -> b) -> a -> b
$ String -> Char -> String
forall r. PrintfType r => String -> r
printf String
"c%x" Char
c

toBeancountMetadataValue :: TagValue -> Text
toBeancountMetadataValue :: BeancountCommoditySymbol -> BeancountCommoditySymbol
toBeancountMetadataValue = (BeancountCommoditySymbol
"\"" BeancountCommoditySymbol
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a. Semigroup a => a -> a -> a
<>) (BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> (BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> BeancountCommoditySymbol
-> BeancountCommoditySymbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BeancountCommoditySymbol
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a. Semigroup a => a -> a -> a
<> BeancountCommoditySymbol
"\"") (BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> (BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> BeancountCommoditySymbol
-> BeancountCommoditySymbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> BeancountCommoditySymbol)
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
T.concatMap Char -> BeancountCommoditySymbol
toBeancountMetadataValueChar

-- | Is this a valid character in the middle of a Beancount metadata name (a lowercase letter, digit, _ or -) ?
isBeancountMetadataValueChar :: Char -> Bool
isBeancountMetadataValueChar :: Char -> Bool
isBeancountMetadataValueChar Char
c = Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char
'"']

-- | 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 :: Char -> BeancountCommoditySymbol
toBeancountMetadataValueChar Char
c
  | Char -> Bool
isBeancountMetadataValueChar Char
c = Char -> BeancountCommoditySymbol
T.singleton Char
c
  | Bool
otherwise = String -> BeancountCommoditySymbol
T.pack (String -> BeancountCommoditySymbol)
-> String -> BeancountCommoditySymbol
forall a b. (a -> b) -> a -> b
$ String -> Char -> String
forall r. PrintfType r => String -> r
printf String
"c%x" Char
c


-- | Render a transaction's postings as indented lines, suitable for `print -O beancount` output.
-- See also Posting.postingsAsLines.
postingsAsLinesBeancount :: [Posting] -> [Text]
postingsAsLinesBeancount :: [Posting] -> [BeancountCommoditySymbol]
postingsAsLinesBeancount [Posting]
ps = (([BeancountCommoditySymbol], Int, Int)
 -> [BeancountCommoditySymbol])
-> [([BeancountCommoditySymbol], Int, Int)]
-> [BeancountCommoditySymbol]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([BeancountCommoditySymbol], Int, Int)
-> [BeancountCommoditySymbol]
forall {a} {b} {c}. (a, b, c) -> a
first3 [([BeancountCommoditySymbol], Int, Int)]
linesWithWidths
  where
    linesWithWidths :: [([BeancountCommoditySymbol], Int, Int)]
linesWithWidths = (Posting -> ([BeancountCommoditySymbol], Int, Int))
-> [Posting] -> [([BeancountCommoditySymbol], Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (Bool
-> Int -> Int -> Posting -> ([BeancountCommoditySymbol], Int, Int)
postingAsLinesBeancount Bool
False Int
maxacctwidth Int
maxamtwidth) [Posting]
ps
    maxacctwidth :: Int
maxacctwidth = Int -> [Int] -> Int
forall a. Ord a => a -> [a] -> a
maximumBound Int
0 ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (([BeancountCommoditySymbol], Int, Int) -> Int)
-> [([BeancountCommoditySymbol], Int, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ([BeancountCommoditySymbol], Int, Int) -> Int
forall {a} {b} {c}. (a, b, c) -> b
second3 [([BeancountCommoditySymbol], Int, Int)]
linesWithWidths
    maxamtwidth :: Int
maxamtwidth  = Int -> [Int] -> Int
forall a. Ord a => a -> [a] -> a
maximumBound Int
0 ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (([BeancountCommoditySymbol], Int, Int) -> Int)
-> [([BeancountCommoditySymbol], Int, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ([BeancountCommoditySymbol], Int, Int) -> Int
forall {a} {b} {c}. (a, b, c) -> c
third3  [([BeancountCommoditySymbol], Int, Int)]
linesWithWidths

-- | 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 :: Bool
-> Int -> Int -> Posting -> ([BeancountCommoditySymbol], Int, Int)
postingAsLinesBeancount Bool
elideamount Int
acctwidth Int
amtwidth Posting
p =
    (([BeancountCommoditySymbol] -> [BeancountCommoditySymbol])
-> [[BeancountCommoditySymbol]] -> [BeancountCommoditySymbol]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([BeancountCommoditySymbol]
-> [BeancountCommoditySymbol] -> [BeancountCommoditySymbol]
forall a. [a] -> [a] -> [a]
++ ((BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> [BeancountCommoditySymbol] -> [BeancountCommoditySymbol]
forall a b. (a -> b) -> [a] -> [b]
map (BeancountCommoditySymbol
"  "BeancountCommoditySymbol
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a. Semigroup a => a -> a -> a
<>) ([BeancountCommoditySymbol] -> [BeancountCommoditySymbol])
-> [BeancountCommoditySymbol] -> [BeancountCommoditySymbol]
forall a b. (a -> b) -> a -> b
$ [BeancountCommoditySymbol]
metadatalines [BeancountCommoditySymbol]
-> [BeancountCommoditySymbol] -> [BeancountCommoditySymbol]
forall a. Semigroup a => a -> a -> a
<> [BeancountCommoditySymbol]
newlinecomments)) [[BeancountCommoditySymbol]]
postingblocks
    ,Int
thisacctwidth
    ,Int
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 :: [[BeancountCommoditySymbol]]
postingblocks = [(BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> [BeancountCommoditySymbol] -> [BeancountCommoditySymbol]
forall a b. (a -> b) -> [a] -> [b]
map BeancountCommoditySymbol -> BeancountCommoditySymbol
T.stripEnd ([BeancountCommoditySymbol] -> [BeancountCommoditySymbol])
-> (Text -> [BeancountCommoditySymbol])
-> Text
-> [BeancountCommoditySymbol]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BeancountCommoditySymbol -> [BeancountCommoditySymbol]
T.lines (BeancountCommoditySymbol -> [BeancountCommoditySymbol])
-> (Text -> BeancountCommoditySymbol)
-> Text
-> [BeancountCommoditySymbol]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> BeancountCommoditySymbol
TL.toStrict (Text -> [BeancountCommoditySymbol])
-> Text -> [BeancountCommoditySymbol]
forall a b. (a -> b) -> a -> b
$
                       [Cell] -> Text
render [ Align -> BeancountCommoditySymbol -> Cell
textCell Align
BottomLeft BeancountCommoditySymbol
statusandaccount
                              , Align -> BeancountCommoditySymbol -> Cell
textCell Align
BottomLeft BeancountCommoditySymbol
"  "
                              , Align -> [WideBuilder] -> Cell
Cell Align
BottomLeft [WideBuilder -> WideBuilder
pad WideBuilder
amt]
                              , Align -> BeancountCommoditySymbol -> Cell
textCell Align
BottomLeft BeancountCommoditySymbol
samelinecomment
                              ]
                    | (WideBuilder
amt,WideBuilder
_assertion) <- [(WideBuilder, WideBuilder)]
shownAmountsAssertions]
    render :: [Cell] -> Text
render = TableOpts -> Header Cell -> Text
renderRow TableOpts
forall a. Default a => a
def{tableBorders=False, borderSpaces=False} (Header Cell -> Text) -> ([Cell] -> Header Cell) -> [Cell] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Properties -> [Header Cell] -> Header Cell
forall h. Properties -> [Header h] -> Header h
Group Properties
NoLine ([Header Cell] -> Header Cell)
-> ([Cell] -> [Header Cell]) -> [Cell] -> Header Cell
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cell -> Header Cell) -> [Cell] -> [Header Cell]
forall a b. (a -> b) -> [a] -> [b]
map Cell -> Header Cell
forall h. h -> Header h
Header
    pad :: WideBuilder -> WideBuilder
pad WideBuilder
amt = Builder -> Int -> WideBuilder
WideBuilder (BeancountCommoditySymbol -> Builder
TB.fromText (BeancountCommoditySymbol -> Builder)
-> BeancountCommoditySymbol -> Builder
forall a b. (a -> b) -> a -> b
$ Int -> BeancountCommoditySymbol -> BeancountCommoditySymbol
T.replicate Int
w BeancountCommoditySymbol
" ") Int
w WideBuilder -> WideBuilder -> WideBuilder
forall a. Semigroup a => a -> a -> a
<> WideBuilder
amt
      where w :: Int
w = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
12 Int
amtwidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- WideBuilder -> Int
wbWidth WideBuilder
amt  -- min. 12 for backwards compatibility

    pacct :: BeancountCommoditySymbol
pacct = Maybe Int -> BeancountCommoditySymbol -> BeancountCommoditySymbol
showAccountNameBeancount Maybe Int
forall a. Maybe a
Nothing (BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a b. (a -> b) -> a -> b
$ Posting -> BeancountCommoditySymbol
paccount Posting
p
    pstatusandacct :: Posting -> BeancountCommoditySymbol
pstatusandacct Posting
p' = if Posting -> Status
pstatus Posting
p' Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
Pending then BeancountCommoditySymbol
"! " else BeancountCommoditySymbol
"" BeancountCommoditySymbol
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a. Semigroup a => a -> a -> a
<> BeancountCommoditySymbol
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 :: [WideBuilder]
shownAmounts
      | Bool
elideamount = [WideBuilder
forall a. Monoid a => a
mempty]
      | Bool
otherwise   = AmountFormat -> MixedAmount -> [WideBuilder]
showMixedAmountLinesB AmountFormat
displayopts MixedAmount
a'
        where
          displayopts :: AmountFormat
displayopts = AmountFormat
defaultFmt{ displayZeroCommodity=True, displayForceDecimalMark=True, displayQuotes=False }
          a' :: MixedAmount
a' = (Amount -> Amount) -> MixedAmount -> MixedAmount
mapMixedAmount Amount -> Amount
amountToBeancount (MixedAmount -> MixedAmount) -> MixedAmount -> MixedAmount
forall a b. (a -> b) -> a -> b
$ Posting -> MixedAmount
pamount Posting
p
    thisamtwidth :: Int
thisamtwidth = Int -> [Int] -> Int
forall a. Ord a => a -> [a] -> a
maximumBound Int
0 ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (WideBuilder -> Int) -> [WideBuilder] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map WideBuilder -> Int
wbWidth [WideBuilder]
shownAmounts

    -- when there is a balance assertion, show it only on the last posting line
    shownAmountsAssertions :: [(WideBuilder, WideBuilder)]
shownAmountsAssertions = [WideBuilder] -> [WideBuilder] -> [(WideBuilder, WideBuilder)]
forall a b. [a] -> [b] -> [(a, b)]
zip [WideBuilder]
shownAmounts [WideBuilder]
shownAssertions
      where
        shownAssertions :: [WideBuilder]
shownAssertions = Int -> WideBuilder -> [WideBuilder]
forall a. Int -> a -> [a]
replicate ([WideBuilder] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [WideBuilder]
shownAmounts Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) WideBuilder
forall a. Monoid a => a
mempty [WideBuilder] -> [WideBuilder] -> [WideBuilder]
forall a. [a] -> [a] -> [a]
++ [WideBuilder
assertion]
          where
            assertion :: WideBuilder
assertion = WideBuilder
-> (BalanceAssertion -> WideBuilder)
-> Maybe BalanceAssertion
-> WideBuilder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe WideBuilder
forall a. Monoid a => a
mempty ((Builder -> Int -> WideBuilder
WideBuilder (Char -> Builder
TB.singleton Char
' ') Int
1 WideBuilder -> WideBuilder -> WideBuilder
forall a. Semigroup a => a -> a -> a
<>)(WideBuilder -> WideBuilder)
-> (BalanceAssertion -> WideBuilder)
-> BalanceAssertion
-> WideBuilder
forall b c a. (b -> c) -> (a -> b) -> a -> c
.BalanceAssertion -> WideBuilder
showBalanceAssertion) (Maybe BalanceAssertion -> WideBuilder)
-> Maybe BalanceAssertion -> WideBuilder
forall a b. (a -> b) -> a -> b
$ Posting -> Maybe BalanceAssertion
pbalanceassertion Posting
p

    -- pad to the maximum account name width, plus 2 to leave room for status flags, to keep amounts aligned
    statusandaccount :: BeancountCommoditySymbol
statusandaccount = BeancountCommoditySymbol -> BeancountCommoditySymbol
postingIndent (BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> (BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> BeancountCommoditySymbol
-> BeancountCommoditySymbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int
-> Maybe Int
-> Bool
-> Bool
-> BeancountCommoditySymbol
-> BeancountCommoditySymbol
fitText (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
acctwidth) Maybe Int
forall a. Maybe a
Nothing Bool
False Bool
True (BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a b. (a -> b) -> a -> b
$ Posting -> BeancountCommoditySymbol
pstatusandacct Posting
p
    thisacctwidth :: Int
thisacctwidth = BeancountCommoditySymbol -> Int
forall a. HasChars a => a -> Int
realLength BeancountCommoditySymbol
pacct
    mds :: [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
mds = [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
-> [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
tagsToBeancountMetadata ([(BeancountCommoditySymbol, BeancountCommoditySymbol)]
 -> [(BeancountCommoditySymbol, BeancountCommoditySymbol)])
-> [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
-> [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
forall a b. (a -> b) -> a -> b
$ Posting -> [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
ptags Posting
p
    metadatalines :: [BeancountCommoditySymbol]
metadatalines = ((BeancountCommoditySymbol, BeancountCommoditySymbol)
 -> BeancountCommoditySymbol)
-> [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
-> [BeancountCommoditySymbol]
forall a b. (a -> b) -> [a] -> [b]
map (BeancountCommoditySymbol -> BeancountCommoditySymbol
postingIndent (BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> ((BeancountCommoditySymbol, BeancountCommoditySymbol)
    -> BeancountCommoditySymbol)
-> (BeancountCommoditySymbol, BeancountCommoditySymbol)
-> BeancountCommoditySymbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int
-> (BeancountCommoditySymbol, BeancountCommoditySymbol)
-> BeancountCommoditySymbol
showBeancountMetadata (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
maxtagnamewidth)) [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
mds
      where maxtagnamewidth :: Int
maxtagnamewidth = [Int] -> Int
forall a. Integral a => [a] -> a
maximum' ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ ((BeancountCommoditySymbol, BeancountCommoditySymbol) -> Int)
-> [(BeancountCommoditySymbol, BeancountCommoditySymbol)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (BeancountCommoditySymbol -> Int
T.length (BeancountCommoditySymbol -> Int)
-> ((BeancountCommoditySymbol, BeancountCommoditySymbol)
    -> BeancountCommoditySymbol)
-> (BeancountCommoditySymbol, BeancountCommoditySymbol)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BeancountCommoditySymbol, BeancountCommoditySymbol)
-> BeancountCommoditySymbol
forall a b. (a, b) -> a
fst) [(BeancountCommoditySymbol, BeancountCommoditySymbol)]
mds
    (BeancountCommoditySymbol
samelinecomment, [BeancountCommoditySymbol]
newlinecomments) =
      case BeancountCommoditySymbol -> [BeancountCommoditySymbol]
renderCommentLines (Posting -> BeancountCommoditySymbol
pcomment Posting
p) of []   -> (BeancountCommoditySymbol
"",[])
                                              BeancountCommoditySymbol
c:[BeancountCommoditySymbol]
cs -> (BeancountCommoditySymbol
c,[BeancountCommoditySymbol]
cs)

-- | Like showAccountName for Beancount journal format.
-- Calls accountNameToBeancount first.
showAccountNameBeancount :: Maybe Int -> AccountName -> Text
showAccountNameBeancount :: Maybe Int -> BeancountCommoditySymbol -> BeancountCommoditySymbol
showAccountNameBeancount Maybe Int
w = (BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> (Int -> BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> Maybe Int
-> BeancountCommoditySymbol
-> BeancountCommoditySymbol
forall b a. b -> (a -> b) -> Maybe a -> b
maybe BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a. a -> a
id Int -> BeancountCommoditySymbol -> BeancountCommoditySymbol
T.take Maybe Int
w (BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> (BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> BeancountCommoditySymbol
-> BeancountCommoditySymbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BeancountCommoditySymbol -> BeancountCommoditySymbol
accountNameToBeancount

type BeancountAccountName = AccountName
type BeancountAccountNameComponent = AccountName

-- | Convert a hledger account name to a valid Beancount account name.
-- It replaces spaces with dashes and other non-supported characters with C<HEXBYTES>;
-- prepends the letter A to any part which doesn't begin with a letter or number;
-- adds a second :A part if there is only one part;
-- and 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
-- raises an informative error.
-- Ref: https://beancount.github.io/docs/beancount_language_syntax.html#accounts
accountNameToBeancount :: AccountName -> BeancountAccountName
accountNameToBeancount :: BeancountCommoditySymbol -> BeancountCommoditySymbol
accountNameToBeancount BeancountCommoditySymbol
a = BeancountCommoditySymbol
b
  where
    cs1 :: [BeancountCommoditySymbol]
cs1 =
      (BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> [BeancountCommoditySymbol] -> [BeancountCommoditySymbol]
forall a b. (a -> b) -> [a] -> [b]
map BeancountCommoditySymbol -> BeancountCommoditySymbol
accountNameComponentToBeancount ([BeancountCommoditySymbol] -> [BeancountCommoditySymbol])
-> [BeancountCommoditySymbol] -> [BeancountCommoditySymbol]
forall a b. (a -> b) -> a -> b
$ BeancountCommoditySymbol -> [BeancountCommoditySymbol]
accountNameComponents (BeancountCommoditySymbol -> [BeancountCommoditySymbol])
-> BeancountCommoditySymbol -> [BeancountCommoditySymbol]
forall a b. (a -> b) -> a -> b
$
      String -> BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a. Show a => String -> a -> a
dbg9 String
"hledger account name  " BeancountCommoditySymbol
a
    cs2 :: [BeancountCommoditySymbol]
cs2 =
      case [BeancountCommoditySymbol]
cs1 of
        BeancountCommoditySymbol
c:[BeancountCommoditySymbol]
_ | BeancountCommoditySymbol
c BeancountCommoditySymbol -> [BeancountCommoditySymbol] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [BeancountCommoditySymbol]
beancountTopLevelAccounts -> String -> [BeancountCommoditySymbol]
forall a. String -> a
error' String
e
          where
            e :: String
e = BeancountCommoditySymbol -> String
T.unpack (BeancountCommoditySymbol -> String)
-> BeancountCommoditySymbol -> String
forall a b. (a -> b) -> a -> b
$ [BeancountCommoditySymbol] -> BeancountCommoditySymbol
T.unlines [
              BeancountCommoditySymbol
"bad top-level account: " BeancountCommoditySymbol
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a. Semigroup a => a -> a -> a
<> BeancountCommoditySymbol
c
              ,BeancountCommoditySymbol
"in beancount account name:           " BeancountCommoditySymbol
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a. Semigroup a => a -> a -> a
<> [BeancountCommoditySymbol] -> BeancountCommoditySymbol
accountNameFromComponents [BeancountCommoditySymbol]
cs1
              ,BeancountCommoditySymbol
"converted from hledger account name: " BeancountCommoditySymbol
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a. Semigroup a => a -> a -> a
<> BeancountCommoditySymbol
a
              ,BeancountCommoditySymbol
"For Beancount, top-level accounts must be (or be --alias'ed to)"
              ,BeancountCommoditySymbol
"one of " BeancountCommoditySymbol
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a. Semigroup a => a -> a -> a
<> BeancountCommoditySymbol
-> [BeancountCommoditySymbol] -> BeancountCommoditySymbol
T.intercalate BeancountCommoditySymbol
", " [BeancountCommoditySymbol]
beancountTopLevelAccounts BeancountCommoditySymbol
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a. Semigroup a => a -> a -> a
<> BeancountCommoditySymbol
"."
              -- ,"and not: " <> b
              ]
        [BeancountCommoditySymbol
c] -> [BeancountCommoditySymbol
c, BeancountCommoditySymbol
"A"]
        [BeancountCommoditySymbol]
cs  -> [BeancountCommoditySymbol]
cs
    b :: BeancountCommoditySymbol
b = String -> BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a. Show a => String -> a -> a
dbg9 String
"beancount account name" (BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a b. (a -> b) -> a -> b
$ [BeancountCommoditySymbol] -> BeancountCommoditySymbol
accountNameFromComponents [BeancountCommoditySymbol]
cs2

accountNameComponentToBeancount :: AccountName -> BeancountAccountNameComponent
accountNameComponentToBeancount :: BeancountCommoditySymbol -> BeancountCommoditySymbol
accountNameComponentToBeancount BeancountCommoditySymbol
acctpart =
  BeancountCommoditySymbol -> BeancountCommoditySymbol
prependStartCharIfNeeded (BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a b. (a -> b) -> a -> b
$
  case BeancountCommoditySymbol -> Maybe (Char, BeancountCommoditySymbol)
T.uncons BeancountCommoditySymbol
acctpart of
    Maybe (Char, BeancountCommoditySymbol)
Nothing -> BeancountCommoditySymbol
""
    Just (Char
c,BeancountCommoditySymbol
cs) ->
      BeancountCommoditySymbol -> BeancountCommoditySymbol
textCapitalise (BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a b. (a -> b) -> a -> b
$
      (Char -> BeancountCommoditySymbol)
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
T.concatMap (\Char
d -> if Char -> Bool
isBeancountAccountChar Char
d then (Char -> BeancountCommoditySymbol
T.singleton Char
d) else String -> BeancountCommoditySymbol
T.pack (String -> BeancountCommoditySymbol)
-> String -> BeancountCommoditySymbol
forall a b. (a -> b) -> a -> b
$ Char -> String
charToBeancount Char
d) (BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a b. (a -> b) -> a -> b
$ Char -> BeancountCommoditySymbol -> BeancountCommoditySymbol
T.cons Char
c BeancountCommoditySymbol
cs
  where
    prependStartCharIfNeeded :: BeancountCommoditySymbol -> BeancountCommoditySymbol
prependStartCharIfNeeded BeancountCommoditySymbol
t =
      case BeancountCommoditySymbol -> Maybe (Char, BeancountCommoditySymbol)
T.uncons BeancountCommoditySymbol
t of
        Just (Char
c,BeancountCommoditySymbol
_) | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Char -> Bool
isBeancountAccountStartChar Char
c -> Char -> BeancountCommoditySymbol -> BeancountCommoditySymbol
T.cons Char
beancountAccountDummyStartChar BeancountCommoditySymbol
t
        Maybe (Char, BeancountCommoditySymbol)
_ -> BeancountCommoditySymbol
t

-- | Dummy valid starting character to prepend to Beancount account name parts if needed (A).
beancountAccountDummyStartChar :: Char
beancountAccountDummyStartChar :: Char
beancountAccountDummyStartChar = Char
'A'

charToBeancount :: Char -> String
charToBeancount :: Char -> String
charToBeancount Char
c = if Char -> Bool
isSpace Char
c then String
"-" else String -> Char -> String
forall r. PrintfType r => String -> r
printf String
"C%x" Char
c

-- XXX these probably allow too much unicode:

-- 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 :: Char -> Bool
isuppercase = Char -> Bool
isUpper
-- same story, presumably
islowercase :: Char -> Bool
islowercase = Char -> Bool
isLower

-- | Is this a valid character to start a Beancount account name part (capital letter or digit) ?
isBeancountAccountStartChar :: Char -> Bool
isBeancountAccountStartChar :: Char -> Bool
isBeancountAccountStartChar Char
c = (Char -> Bool
isLetter Char
c Bool -> Bool -> Bool
&& Char -> Bool
isuppercase Char
c) Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c

-- | Is this a valid character to appear elsewhere in a Beancount account name part (letter, digit, or -) ?
isBeancountAccountChar :: Char -> Bool
isBeancountAccountChar :: Char -> Bool
isBeancountAccountChar Char
c = Char -> Bool
isLetter Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| Char
cChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'-'

beancountTopLevelAccounts :: [BeancountCommoditySymbol]
beancountTopLevelAccounts = [BeancountCommoditySymbol
"Assets", BeancountCommoditySymbol
"Liabilities", BeancountCommoditySymbol
"Equity", BeancountCommoditySymbol
"Income", BeancountCommoditySymbol
"Expenses"]

type BeancountAmount = Amount

-- | Do some best effort adjustments to make an amount that renders
-- in a way that Beancount can read: force the commodity symbol to the right,
-- capitalise all letters, convert a few currency symbols to codes.
amountToBeancount :: Amount -> BeancountAmount
amountToBeancount :: Amount -> Amount
amountToBeancount a :: Amount
a@Amount{acommodity :: Amount -> BeancountCommoditySymbol
acommodity=BeancountCommoditySymbol
c,astyle :: Amount -> AmountStyle
astyle=AmountStyle
s,acost :: Amount -> Maybe AmountCost
acost=Maybe AmountCost
mp} = Amount
a{acommodity=c', astyle=s', acost=mp'}
  where
    c' :: BeancountCommoditySymbol
c' = BeancountCommoditySymbol -> BeancountCommoditySymbol
commodityToBeancount BeancountCommoditySymbol
c
    s' :: AmountStyle
s' = AmountStyle
s{ascommodityside=R, ascommodityspaced=True}
    mp' :: Maybe AmountCost
mp' = AmountCost -> AmountCost
costToBeancount (AmountCost -> AmountCost) -> Maybe AmountCost -> Maybe AmountCost
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe AmountCost
mp
      where
        costToBeancount :: AmountCost -> AmountCost
costToBeancount (TotalCost Amount
amt) = Amount -> AmountCost
TotalCost (Amount -> AmountCost) -> Amount -> AmountCost
forall a b. (a -> b) -> a -> b
$ Amount -> Amount
amountToBeancount Amount
amt
        costToBeancount (UnitCost  Amount
amt) = Amount -> AmountCost
UnitCost  (Amount -> AmountCost) -> Amount -> AmountCost
forall a b. (a -> b) -> a -> b
$ Amount -> Amount
amountToBeancount Amount
amt

type BeancountCommoditySymbol = CommoditySymbol

-- | Convert a hledger commodity name to a valid Beancount commodity name.
-- That is: 2-24 uppercase letters / digits / apostrophe / period / underscore / dash,
-- starting with a letter, and ending with a letter or digit.
-- Ref: https://beancount.github.io/docs/beancount_language_syntax.html#commodities-currencies
-- So this:
-- replaces common currency symbols with their ISO 4217 currency codes,
-- capitalises all letters,
-- replaces spaces with dashes and other invalid characters with C<HEXBYTES>,
-- prepends a C if the first character is not a letter,
-- appends a C if the last character is not a letter or digit,
-- and disables hledger's enclosing double quotes.
--
-- >>> commodityToBeancount ""
-- "C"
-- >>> commodityToBeancount "$"
-- "USD"
-- >>> commodityToBeancount "Usd"
-- "USD"
-- >>> commodityToBeancount "\"a1\""
-- "A1"
-- >>> commodityToBeancount "\"A 1!\""
-- "A-1C21"
--
commodityToBeancount :: CommoditySymbol -> BeancountCommoditySymbol
commodityToBeancount :: BeancountCommoditySymbol -> BeancountCommoditySymbol
commodityToBeancount BeancountCommoditySymbol
com =
  String -> BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a. Show a => String -> a -> a
dbg9 String
"beancount commodity name" (BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a b. (a -> b) -> a -> b
$
  let com' :: BeancountCommoditySymbol
com' = BeancountCommoditySymbol -> BeancountCommoditySymbol
stripquotes BeancountCommoditySymbol
com
  in case BeancountCommoditySymbol -> Maybe BeancountCommoditySymbol
currencySymbolToCode BeancountCommoditySymbol
com' of
    Just BeancountCommoditySymbol
code -> BeancountCommoditySymbol
code
    Maybe BeancountCommoditySymbol
Nothing ->
      BeancountCommoditySymbol
com'
      BeancountCommoditySymbol
-> (BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> BeancountCommoditySymbol
forall a b. a -> (a -> b) -> b
& BeancountCommoditySymbol -> BeancountCommoditySymbol
T.toUpper
      BeancountCommoditySymbol
-> (BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> BeancountCommoditySymbol
forall a b. a -> (a -> b) -> b
& (Char -> BeancountCommoditySymbol)
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
T.concatMap (\Char
d -> if Char -> Bool
isBeancountCommodityChar Char
d then Char -> BeancountCommoditySymbol
T.singleton Char
d else String -> BeancountCommoditySymbol
T.pack (String -> BeancountCommoditySymbol)
-> String -> BeancountCommoditySymbol
forall a b. (a -> b) -> a -> b
$ Char -> String
charToBeancount Char
d)
      BeancountCommoditySymbol
-> (BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> BeancountCommoditySymbol
forall a b. a -> (a -> b) -> b
& BeancountCommoditySymbol -> BeancountCommoditySymbol
fixstart
      BeancountCommoditySymbol
-> (BeancountCommoditySymbol -> BeancountCommoditySymbol)
-> BeancountCommoditySymbol
forall a b. a -> (a -> b) -> b
& BeancountCommoditySymbol -> BeancountCommoditySymbol
fixend
  where
    fixstart :: BeancountCommoditySymbol -> BeancountCommoditySymbol
fixstart BeancountCommoditySymbol
bcom = case BeancountCommoditySymbol -> Maybe (Char, BeancountCommoditySymbol)
T.uncons BeancountCommoditySymbol
bcom of
      Just (Char
c,BeancountCommoditySymbol
_) | Char -> Bool
isBeancountCommodityStartChar Char
c -> BeancountCommoditySymbol
bcom
      Maybe (Char, BeancountCommoditySymbol)
_ -> BeancountCommoditySymbol
"C" BeancountCommoditySymbol
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a. Semigroup a => a -> a -> a
<> BeancountCommoditySymbol
bcom
    fixend :: BeancountCommoditySymbol -> BeancountCommoditySymbol
fixend BeancountCommoditySymbol
bcom = case BeancountCommoditySymbol -> Maybe (BeancountCommoditySymbol, Char)
T.unsnoc BeancountCommoditySymbol
bcom of
      Just (BeancountCommoditySymbol
_,Char
c) | Char -> Bool
isBeancountCommodityEndChar Char
c -> BeancountCommoditySymbol
bcom
      Maybe (BeancountCommoditySymbol, Char)
_ -> BeancountCommoditySymbol
bcom BeancountCommoditySymbol
-> BeancountCommoditySymbol -> BeancountCommoditySymbol
forall a. Semigroup a => a -> a -> a
<> BeancountCommoditySymbol
"C"

-- | Is this a valid character in the middle of a Beancount commodity name (a capital letter, digit, or '._-) ?
isBeancountCommodityChar :: Char -> Bool
isBeancountCommodityChar :: Char -> Bool
isBeancountCommodityChar Char
c = (Char -> Bool
isLetter Char
c Bool -> Bool -> Bool
&& Char -> Bool
isuppercase Char
c) Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'\'', Char
'.', Char
'_', Char
'-']

-- | Is this a valid character to start a Beancount commodity name (a capital letter) ?
isBeancountCommodityStartChar :: Char -> Bool
isBeancountCommodityStartChar :: Char -> Bool
isBeancountCommodityStartChar Char
c = Char -> Bool
isLetter Char
c Bool -> Bool -> Bool
&& Char -> Bool
isuppercase Char
c

-- | Is this a valid character to end a Beancount commodity name (a capital letter or digit) ?
isBeancountCommodityEndChar :: Char -> Bool
isBeancountCommodityEndChar :: Char -> Bool
isBeancountCommodityEndChar Char
c = (Char -> Bool
isLetter Char
c Bool -> Bool -> Bool
&& Char -> Bool
isuppercase Char
c) Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c

--- ** tests

tests_WriteBeancount :: TestTree
tests_WriteBeancount :: TestTree
tests_WriteBeancount = String -> [TestTree] -> TestTree
testGroup String
"Write.Beancount" [
  ]