content: {-|
  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 Data.Text qualified as T
  import Data.Text.Lazy qualified as TL
  import Data.Text.Lazy.Builder qualified 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 t =
    -- https://beancount.github.io/docs/beancount_language_syntax.html
    -- similar to showTransactionHelper, but I haven't bothered with Builder
       firstline <> nl
    <> foldMap ((<> nl).postingIndent.showBeancountMetadata (Just maxmdnamewidth)) mds
    <> foldMap ((<> nl)) newlinecomments
    <> foldMap ((<> nl)) (postingsAsLinesBeancount $ tpostings t)
    <> nl
    where
      firstline = T.concat [date, status, payee, note, 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
      mds = tagsToBeancountMetadata $ ttags t
      maxmdnamewidth = maximum' $ map (T.length . fst) mds
      (samelinecomment, newlinecomments) =
        case renderCommentLines (tcomment t) of []   -> ("",[])
                                                c:cs -> (c,cs)
  
  nl = "\n"
  
  type BMetadata = Tag
  
  -- https://beancount.github.io/docs/beancount_language_syntax.html#metadata-1
  -- | Render a Beancount metadata as a metadata line (without the indentation or newline).
  -- If a maximum name length is provided, space will be left after the colon
  -- so that successive metadata values will all start at the same column.
  showBeancountMetadata :: Maybe Int -> BMetadata -> Text
  showBeancountMetadata mmaxnamewidth (n,v) =
    fitText (fmap (+2) mmaxnamewidth) Nothing False True (n <> ": ")
    <> toBeancountMetadataValue v
  
  -- | Make a list of tags ready to be rendered as Beancount metadata:
  -- Encode and lengthen names, encode values, and combine repeated tags into one.
  -- Metadatas will be sorted by (encoded) name and then value.
  tagsToBeancountMetadata :: [Tag] -> [BMetadata]
  tagsToBeancountMetadata = sort . map (first toBeancountMetadataName) . uniquifyTags . filter (not.isHiddenTagName.fst)
  
  -- | In a list of tags, replace each tag that appears more than once
  -- with a single tag with all of the values combined into one, comma-and-space-separated.
  -- This function also sorts all tags by name and then value.
  uniquifyTags :: [Tag] -> [Tag]
  uniquifyTags ts = [(k, T.intercalate ", " $ map snd $ tags) | (k, tags) <- groupOnKey fst $ sort ts]
  
  toBeancountMetadataName :: TagName -> Text
  toBeancountMetadataName name =
    prependStartCharIfNeeded $
    case T.uncons name of
      Nothing -> ""
      Just (c,cs) ->
        T.concatMap (\d -> if isBeancountMetadataNameChar d then T.singleton d else toBeancountMetadataNameChar d) $ T.cons c cs
    where
      -- If the name is empty, make it "mm".
      -- If it has only one character, prepend "m".
      -- If the first character is not a valid one, prepend "m".
      prependStartCharIfNeeded t =
        case T.uncons t of
          Nothing -> T.replicate 2 $ T.singleton beancountMetadataDummyNameStartChar
          Just (c,cs) | T.null cs || not (isBeancountMetadataNameStartChar c) -> T.cons beancountMetadataDummyNameStartChar t
          _ -> t
  
  -- | Is this a valid character to start a Beancount metadata name (lowercase letter) ?
  isBeancountMetadataNameStartChar :: Char -> Bool
  isBeancountMetadataNameStartChar c = isLetter c && islowercase c
  
  -- | Dummy valid starting character to prepend to a Beancount metadata name if needed.
  beancountMetadataDummyNameStartChar :: Char
  beancountMetadataDummyNameStartChar = 'm'
  
  -- | Is this a valid character in the middle of a Beancount metadata name (a lowercase letter, digit, _ or -) ?
  isBeancountMetadataNameChar :: Char -> Bool
  isBeancountMetadataNameChar c = (isLetter c && islowercase c) || isDigit c || c `elem` ['_', '-']
  
  -- | Convert a character to one or more characters valid inside a Beancount metadata name.
  -- Letters are lowercased, spaces are converted to dashes, and unsupported characters are encoded as c<HEXBYTES>.
  toBeancountMetadataNameChar :: Char -> Text
  toBeancountMetadataNameChar c
    | isBeancountMetadataNameChar c = T.singleton c
    | isLetter c = T.singleton $ toLower c
    | isSpace c = "-"
    | otherwise = T.pack $ printf "c%x" c
  
  toBeancountMetadataValue :: TagValue -> Text
  toBeancountMetadataValue = ("\"" <>) . (<> "\"") . T.concatMap toBeancountMetadataValueChar
  
  -- | Is this a valid character in the middle of a Beancount metadata name (a lowercase letter, digit, _ or -) ?
  isBeancountMetadataValueChar :: Char -> Bool
  isBeancountMetadataValueChar c = c `notElem` ['"']
  
  -- | Convert a character to one or more characters valid inside a Beancount metadata value:
  -- a double quote is encoded as c<HEXBYTES>.
  toBeancountMetadataValueChar :: Char -> Text
  toBeancountMetadataValueChar c
    | isBeancountMetadataValueChar c = T.singleton c
    | otherwise = T.pack $ printf "c%x" c
  
  
  -- | Render a transaction's postings as indented lines, suitable for `print -O beancount` output.
  -- See also Posting.postingsAsLines.
  postingsAsLinesBeancount :: [Posting] -> [Text]
  postingsAsLinesBeancount ps = concatMap first3 linesWithWidths
    where
      linesWithWidths = map (postingAsLinesBeancount False maxacctwidth maxamtwidth) ps
      maxacctwidth = maximumBound 0 $ map second3 linesWithWidths
      maxamtwidth  = maximumBound 0 $ map third3  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 elideamount acctwidth amtwidth p =
      (concatMap (++ (map ("  "<>) $ metadatalines <> newlinecomments)) postingblocks
      ,thisacctwidth
      ,thisamtwidth
      )
    where
      -- This needs to be converted to strict Text in order to strip trailing
      -- spaces. This adds a small amount of inefficiency, and the only difference
      -- 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, displayQuotes=False }
            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
      mds = tagsToBeancountMetadata $ ptags p
      metadatalines = map (postingIndent . showBeancountMetadata (Just maxtagnamewidth)) mds
        where maxtagnamewidth = maximum' $ map (T.length . fst) mds
      (samelinecomment, newlinecomments) =
        case renderCommentLines (pcomment p) of []   -> ("",[])
                                                c:cs -> (c,cs)
  
  -- | 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 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 a = b
    where
      cs1 =
        map accountNameComponentToBeancount $ accountNameComponents $
        dbg9 "hledger account name  " a
      cs2 =
        case cs1 of
          c:_ | c `notElem` beancountTopLevelAccounts -> error' e
            where
              e = T.unpack $ T.unlines [
                "bad top-level account: " <> c
                ,"in beancount account name:           " <> accountNameFromComponents cs1
                ,"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
                ]
          [c] -> [c, "A"]
          cs  -> cs
      b = dbg9 "beancount account name" $ accountNameFromComponents cs2
  
  accountNameComponentToBeancount :: AccountName -> BeancountAccountNameComponent
  accountNameComponentToBeancount acctpart =
    prependStartCharIfNeeded $
    case T.uncons acctpart of
      Nothing -> ""
      Just (c,cs) ->
        textCapitalise $
        T.concatMap (\d -> if isBeancountAccountChar d then (T.singleton d) else T.pack $ charToBeancount d) $ 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 (A).
  beancountAccountDummyStartChar :: Char
  beancountAccountDummyStartChar = 'A'
  
  charToBeancount :: Char -> String
  charToBeancount c = if isSpace c then "-" else printf "C%x" 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 = isUpper
  -- same story, presumably
  islowercase = isLower
  
  -- | Is this a valid character to start a Beancount account name part (capital letter or digit) ?
  isBeancountAccountStartChar :: Char -> Bool
  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: force the commodity symbol to the right,
  -- capitalise all letters, convert a few currency symbols to codes.
  amountToBeancount :: Amount -> BeancountAmount
  amountToBeancount a@Amount{acommodity=c,astyle=s,acost=mp} = a{acommodity=c', astyle=s', acost=mp'}
    where
      c' = commodityToBeancount c
      s' = s{ascommodityside=R, ascommodityspaced=True}
      mp' = costToBeancount <$> mp
        where
          costToBeancount (TotalCost amt) = TotalCost $ amountToBeancount amt
          costToBeancount (UnitCost  amt) = UnitCost  $ amountToBeancount 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 com =
    dbg9 "beancount commodity name" $
    let com' = stripquotes com
    in case currencySymbolToCode com' of
      Just code -> code
      Nothing ->
        com'
        & T.toUpper
        & T.concatMap (\d -> if isBeancountCommodityChar d then T.singleton d else T.pack $ charToBeancount d)
        & fixstart
        & fixend
    where
      fixstart bcom = case T.uncons bcom of
        Just (c,_) | isBeancountCommodityStartChar c -> bcom
        _ -> "C" <> bcom
      fixend bcom = case T.unsnoc bcom of
        Just (_,c) | isBeancountCommodityEndChar c -> bcom
        _ -> bcom <> "C"
  
  -- | Is this a valid character in the middle of a Beancount commodity name (a capital letter, digit, or '._-) ?
  isBeancountCommodityChar :: Char -> Bool
  isBeancountCommodityChar c = (isLetter c && isuppercase c) || isDigit c || c `elem` ['\'', '.', '_', '-']
  
  -- | Is this a valid character to start a Beancount commodity name (a capital letter) ?
  isBeancountCommodityStartChar :: Char -> Bool
  isBeancountCommodityStartChar c = isLetter c && isuppercase c
  
  -- | Is this a valid character to end a Beancount commodity name (a capital letter or digit) ?
  isBeancountCommodityEndChar :: Char -> Bool
  isBeancountCommodityEndChar c = (isLetter c && isuppercase c) || isDigit c
  
  --- ** tests
  
  tests_WriteBeancount :: TestTree
  tests_WriteBeancount = testGroup "Write.Beancount" [
    ]
  