1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
|
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.RWS
import Data.Maybe
import Data.Time.Calendar
import Data.Time.Calendar.OrdinalDate
import Numeric
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
}
data InterestState = InterestState
{ balancedUntil :: Day
, balance :: MixedAmount
}
nullInterestState :: InterestState
nullInterestState = InterestState
{ balancedUntil = nulldate
, balance = 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 = normaliseMixedAmountPreservingFirstPrice (bal + (pamount p)) })
computeInterest :: Day -> Computer ()
computeInterest 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 (isZeroMixedAmount bal)) $ do
diff <- asks dayCountConvention
t <- mkTrans to ((from `diff` to) + 1) ratePerAnno
tell [t]
processTransaction t
when (newFrom < day) (computeInterest day)
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
mkTrans :: Day -> Integer -> Double -> Computer Transaction
mkTrans day days ratePerAnno = do
bal <- gets balance
srcAcc <- asks sourceAccount
targetAcc <- asks targetAccount
perDayScalar <- daysInYear day
let t = Transaction
{ tdate = day
, tdate2 = Nothing
, tstatus = False
, tcode = ""
, tdescription = showPercent ratePerAnno ++ "% interest for " ++ showMixedAmount bal ++ " over " ++ show days ++ " days"
, tcomment = ""
, tpostings = [pTarget,pSource]
, tpreceding_comment_lines = ""
, ttags = []
}
pTarget = Posting
{ pdate = Nothing
, pdate2 = Nothing
, pstatus = False
, paccount = targetAcc
, pamount = Mixed [ a { aquantity = (aquantity a * ratePerAnno) / fromInteger perDayScalar * fromInteger days } | a <- amounts bal ]
, pcomment = ""
, ptype = RegularPosting
, ptransaction = Just t
, ptags = []
}
pSource = Posting
{ pdate = Nothing
, pdate2 = Nothing
, pstatus = False
, paccount = srcAcc
, pamount = negate (pamount pTarget)
, pcomment = ""
, ptype = RegularPosting
, ptransaction = Just t
, ptags = []
}
return t
showPercent :: Double -> String
showPercent r = showWith2Digits (r * 100)
showWith2Digits :: Double -> String
showWith2Digits r = showFFloat (Just 2) r ""
|
