hledger-interest-1.7.0: Hledger/Interest.hs

module Hledger.Interest
  ( Computer, runComputer
  , Config(..)
  , InterestState(..), nullInterestState
  , processTransaction, computeInterest
  , module Hledger.Interest.DayCountConvention
  , module Hledger.Interest.Rate
  , module Hledger.Data
  )
  where

import Hledger.Data
import Hledger.Interest.DayCountConvention
import Hledger.Interest.Rate

import Control.Monad
import Control.Monad.RWS
import Data.Decimal
import Data.Maybe
import qualified Data.Text as T
import Data.Time.Calendar
import Data.Time.Calendar.OrdinalDate

type Computer = RWS Config [Transaction] InterestState

runComputer :: Config -> Computer () -> [Transaction]
runComputer cfg f = ts
  where ((),_,ts) = runRWS f cfg nullInterestState

data Config = Config
  { interestAccount :: AccountName
  , sourceAccount :: AccountName
  , targetAccount :: AccountName
  , dayCountConvention :: DayCountConvention
  , interestRate :: Rate
  , postOnTransactions :: Bool
    -- ^ Post accrued interest only on transaction dates rather than at the
    -- end of every rate period (e.g. at every year end with 'perAnno').
  }

data InterestState = InterestState
  { balancedUntil :: Day
  , balance :: MixedAmount
  , accruedDays :: Integer          -- ^ interest accrued but not posted yet
  , accruedInterest :: MixedAmount
  }

nullInterestState :: InterestState
nullInterestState = InterestState
  { balancedUntil = nulldate
  , balance = nullmixedamt
  , accruedDays = 0
  , accruedInterest = nullmixedamt
  }

processTransaction :: Transaction -> Computer ()
processTransaction ts = do
  let day = fromMaybe (tdate ts) (tdate2 ts)
  computeInterest day
  interestAcc <- asks interestAccount
  let posts = [ p | p <- tpostings ts, interestAcc == paccount p ]
  forM_ posts $ \p -> do
    bal <- gets balance
    modify (\st -> st { balance = bal + pamount p })

-- | Compute and post all interest up to and including the given day.
computeInterest :: Day -> Computer ()
computeInterest day = accrueInterest day >> postInterest day Nothing

accrueInterest :: Day -> Computer ()
accrueInterest day = do
  from <- gets balancedUntil
  bal <- gets balance
  rate <- asks interestRate
  let (endOfPeriod,ratePerAnno) = rate from
      to = min day endOfPeriod
      newFrom = succ to
  modify (\st -> st { balancedUntil = newFrom })
  when (to >= from && not (mixedAmountIsZero bal)) $ do
    diff <- asks dayCountConvention
    yearDays <- daysInYear to
    let days = (from `diff` to) + 1
        interest = mixed [ a { aquantity = (aquantity a * ratePerAnno) / fromInteger yearDays * fromInteger days } | a <- amounts bal ]
    modify (\st -> st { accruedDays = accruedDays st + days
                      , accruedInterest = accruedInterest st + interest
                      })
    onTransactionsOnly <- asks postOnTransactions
    unless onTransactionsOnly (postInterest to (Just ratePerAnno))
  when (newFrom <= day) (accrueInterest day)

-- | Post all accrued interest as one transaction on the given day. The
-- description mentions the rate only if one is given, i.e. if the interest
-- was accrued over a single rate period.
postInterest :: Day -> Maybe Decimal -> Computer ()
postInterest day ratePerAnno = do
  st <- get
  when (accruedDays st > 0) $ do
    put st { accruedDays = 0, accruedInterest = nullmixedamt }
    t <- mkTrans day (accruedDays st) (accruedInterest st) ratePerAnno
    tell [t]
    processTransaction t

daysInYear :: Day -> Computer Integer
daysInYear now = asks dayCountConvention >>= \diff -> return (day1 `diff` day2)
  where day1 = fromGregorian (fst (toOrdinalDate now)) 1 1
        day2 = fromGregorian (succ (fst (toOrdinalDate now))) 1 1

-- | Create the transaction for the given interest, which was accrued over
-- the given number of days.
mkTrans :: Day -> Integer -> MixedAmount -> Maybe Decimal -> Computer Transaction
mkTrans day days interest ratePerAnno = do
  bal <- gets balance
  srcAcc <- asks sourceAccount
  targetAcc <- asks targetAccount
  let t = nulltransaction
          { tdate          = day
          , tdescription   = T.pack $ maybe "" (\r -> showPercent r ++ " ") ratePerAnno ++ "interest for " ++ showMixedAmountOneLine bal ++ " over " ++ show days ++ " days"
          , tpostings      = [pTarget,pSource]
          }
      -- balance might have been an exact amount, in which case its precision might
      -- be set to 0 decimal places. We ensure that interest is displayed with at least
      -- two decimal points
      pTarget = nullposting
          { paccount       = targetAcc
          , pamount        = mixed [ setMinPrecision 2 a | a <- amounts interest ]
          , ptype          = RegularPosting
          , ptransaction   = Just t
          }
      pSource = nullposting
          { paccount       = srcAcc
          , pamount        = negate (pamount pTarget)
          , ptype          = RegularPosting
          , ptransaction   = Just t
          }
  return t
  where
    -- Copy of amountSetPrecisionMin (with amountDisplayPrecision inlined) from
    -- hledger-lib >= 1.32, which older hledger-lib versions (still allowed by our
    -- lower bound) do not provide
    setMinPrecision minp a = amountSetPrecision (Precision $ max minp displayPrecision) a
      where
        displayPrecision =
          case asprecision $ astyle a of
            Precision n      -> n
            NaturalPrecision -> decimalPlaces (normalizeDecimal (aquantity a))

showPercent :: Decimal -> String
showPercent r = shows (r * 100) "%"