570 lines
18 KiB
Haskell
570 lines
18 KiB
Haskell
module Internal.Budget (insertBudget) where
|
|
|
|
import Control.Monad.Except
|
|
import Data.Foldable
|
|
import Database.Persist.Monad
|
|
import Internal.Database
|
|
import Internal.Types.Main
|
|
import Internal.Utils
|
|
import RIO hiding (to)
|
|
import qualified RIO.List as L
|
|
import qualified RIO.Map as M
|
|
import qualified RIO.NonEmpty as NE
|
|
import qualified RIO.Text as T
|
|
import RIO.Time
|
|
|
|
-- each budget (designated at the top level by a 'name') is processed in the
|
|
-- following steps
|
|
-- 1. expand all transactions given the desired date range and date patterns for
|
|
-- each directive in the budget
|
|
-- 2. sort all transactions by date
|
|
-- 3. propagate all balances forward, and while doing so assign values to each
|
|
-- transaction (some of which depend on the 'current' balance of the
|
|
-- target account)
|
|
-- 4. assign shadow transactions
|
|
-- 5. insert all transactions
|
|
|
|
insertBudget
|
|
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
|
=> Budget
|
|
-> m ()
|
|
insertBudget
|
|
b@Budget
|
|
{ bgtLabel
|
|
, bgtIncomes
|
|
, bgtTransfers
|
|
, bgtShadowTransfers
|
|
, bgtPretax
|
|
, bgtTax
|
|
, bgtPosttax
|
|
, bgtInterval
|
|
} =
|
|
whenHash CTBudget b () $ \key -> do
|
|
(intAllos, _) <- combineError intAlloRes acntRes (,)
|
|
let res1 = mapErrors (insertIncome key bgtLabel intAllos bgtInterval) bgtIncomes
|
|
let res2 = expandTransfers key bgtLabel bgtInterval bgtTransfers
|
|
txs <- combineError (concat <$> res1) res2 (++)
|
|
m <- askDBState kmCurrency
|
|
shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs
|
|
void $ mapErrors insertBudgetTx $ balanceTransfers $ txs ++ shadow
|
|
where
|
|
acntRes = mapErrors isNotIncomeAcnt alloAcnts
|
|
intAlloRes = combineError3 pre_ tax_ post_ (,,)
|
|
pre_ = sortAllos bgtPretax
|
|
tax_ = sortAllos bgtTax
|
|
post_ = sortAllos bgtPosttax
|
|
sortAllos = liftExcept . mapErrors sortAllo
|
|
alloAcnts =
|
|
(alloAcnt <$> bgtPretax)
|
|
++ (alloAcnt <$> bgtTax)
|
|
++ (alloAcnt <$> bgtPosttax)
|
|
|
|
balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer]
|
|
balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen
|
|
where
|
|
go bals f@FlatTransfer {ftFrom, ftTo, ftValue = UnbalancedValue {cvValue, cvType}} =
|
|
let balTo = M.findWithDefault 0 ftTo bals
|
|
x = amtToMove balTo cvType cvValue
|
|
bals' = mapAdd_ ftTo x $ mapAdd_ ftFrom (-x) bals
|
|
in (bals', f {ftValue = x})
|
|
-- TODO might need to query signs to make this intuitive; as it is this will
|
|
-- probably work, but for credit accounts I might need to supply a negative
|
|
-- target value
|
|
amtToMove _ BTFixed x = x
|
|
amtToMove bal BTPercent x = -(x / 100 * bal)
|
|
amtToMove bal BTTarget x = x - bal
|
|
|
|
insertBudgetTx
|
|
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
|
=> BalancedTransfer
|
|
-> m ()
|
|
insertBudgetTx FlatTransfer {ftFrom, ftTo, ftMeta, ftCur, ftValue, ftDesc, ftWhen} = do
|
|
((sFrom, sTo), exchange) <- entryPair ftFrom ftTo ftCur ftValue
|
|
insertPair sFrom sTo
|
|
forM_ exchange $ uncurry insertPair
|
|
where
|
|
insertPair from to = do
|
|
k <- insert $ TransactionR (bmCommit ftMeta) ftWhen ftDesc
|
|
insertBudgetLabel k from
|
|
insertBudgetLabel k to
|
|
insertBudgetLabel k entry = do
|
|
sk <- insertEntry k entry
|
|
insert_ $ BudgetLabelR sk $ bmName ftMeta
|
|
|
|
entryPair
|
|
:: (MonadInsertError m, MonadFinance m)
|
|
=> TaggedAcnt
|
|
-> TaggedAcnt
|
|
-> BudgetCurrency
|
|
-> Rational
|
|
-> m (EntryPair, Maybe EntryPair)
|
|
entryPair from to cur val = case cur of
|
|
NoX curid -> (,Nothing) <$> pair curid from to val
|
|
X Exchange {xFromCur, xToCur, xAcnt, xRate} -> do
|
|
let middle = TaggedAcnt xAcnt []
|
|
let res1 = pair xFromCur from middle val
|
|
let res2 = pair xToCur middle to (val * roundPrecision 3 xRate)
|
|
combineError res1 res2 $ \a b -> (a, Just b)
|
|
where
|
|
pair curid from_ to_ v = do
|
|
let s1 = entry curid from_ (-v)
|
|
let s2 = entry curid to_ v
|
|
combineError s1 s2 (,)
|
|
entry c TaggedAcnt {taAcnt, taTags} v =
|
|
resolveEntry $
|
|
FullEntry
|
|
{ feCurrency = c
|
|
, feEntry =
|
|
Entry
|
|
{ eAcnt = taAcnt
|
|
, eValue = v
|
|
, eComment = ""
|
|
, eTags = taTags
|
|
}
|
|
}
|
|
|
|
sortAllo :: MultiAllocation v -> InsertExcept (DaySpanAllocation v)
|
|
sortAllo a@Allocation {alloAmts = as} = do
|
|
bs <- foldSpan [] $ L.sortOn amtWhen as
|
|
return $ a {alloAmts = reverse bs}
|
|
where
|
|
foldSpan acc [] = return acc
|
|
foldSpan acc (x : xs) = do
|
|
let start = amtWhen x
|
|
res <- case xs of
|
|
[] -> resolveDaySpan start
|
|
(y : _) -> resolveDaySpan_ (intStart $ amtWhen y) start
|
|
foldSpan (x {amtWhen = res} : acc) xs
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Income
|
|
|
|
-- TODO this will scan the interval allocations fully each time
|
|
-- iteration which is a total waste, but the fix requires turning this
|
|
-- loop into a fold which I don't feel like doing now :(
|
|
insertIncome
|
|
:: (MonadInsertError m, MonadFinance m)
|
|
=> CommitRId
|
|
-> T.Text
|
|
-> IntAllocations
|
|
-> Maybe Interval
|
|
-> Income
|
|
-> m [UnbalancedTransfer]
|
|
insertIncome
|
|
key
|
|
name
|
|
(intPre, intTax, intPost)
|
|
localInterval
|
|
Income
|
|
{ incWhen
|
|
, incCurrency
|
|
, incFrom
|
|
, incPretax
|
|
, incPosttax
|
|
, incTaxes
|
|
, incToBal
|
|
, incGross
|
|
, incPayPeriod
|
|
} =
|
|
combineErrorM
|
|
(combineError incRes nonIncRes (,))
|
|
(combineError precRes dayRes (,))
|
|
$ \_ (precision, days) -> do
|
|
let gross = roundPrecision precision incGross
|
|
concat <$> foldDays (allocate precision gross) start days
|
|
where
|
|
incRes = isIncomeAcnt $ taAcnt incFrom
|
|
nonIncRes =
|
|
mapErrors isNotIncomeAcnt $
|
|
taAcnt incToBal
|
|
: (alloAcnt <$> incPretax)
|
|
++ (alloAcnt <$> incTaxes)
|
|
++ (alloAcnt <$> incPosttax)
|
|
precRes = lookupCurrencyPrec incCurrency
|
|
dayRes = askDays incWhen localInterval
|
|
start = fromGregorian' $ pStart incPayPeriod
|
|
pType' = pType incPayPeriod
|
|
meta = BudgetMeta key name
|
|
flatPre = concatMap flattenAllo incPretax
|
|
flatTax = concatMap flattenAllo incTaxes
|
|
flatPost = concatMap flattenAllo incPosttax
|
|
sumAllos = sum . fmap faValue
|
|
-- TODO ensure these are all the "correct" accounts
|
|
allocate precision gross prevDay day = do
|
|
scaler <- liftExcept $ periodScaler pType' prevDay day
|
|
let (preDeductions, pre) =
|
|
allocatePre precision gross $
|
|
flatPre ++ concatMap (selectAllos day) intPre
|
|
tax =
|
|
allocateTax precision gross preDeductions scaler $
|
|
flatTax ++ concatMap (selectAllos day) intTax
|
|
aftertaxGross = gross - sumAllos (tax ++ pre)
|
|
post =
|
|
allocatePost precision aftertaxGross $
|
|
flatPost ++ concatMap (selectAllos day) intPost
|
|
balance = aftertaxGross - sumAllos post
|
|
bal =
|
|
FlatTransfer
|
|
{ ftMeta = meta
|
|
, ftWhen = day
|
|
, ftFrom = incFrom
|
|
, ftCur = NoX incCurrency
|
|
, ftTo = incToBal
|
|
, ftValue = UnbalancedValue BTFixed balance
|
|
, ftDesc = "balance after deductions"
|
|
}
|
|
in if balance < 0
|
|
then throwError $ InsertException [IncomeError day name balance]
|
|
else return (bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post))
|
|
|
|
periodScaler
|
|
:: PeriodType
|
|
-> Day
|
|
-> Day
|
|
-> InsertExcept PeriodScaler
|
|
periodScaler pt prev cur = return scale
|
|
where
|
|
n = fromIntegral $ workingDays wds prev cur
|
|
wds = case pt of
|
|
Hourly HourlyPeriod {hpWorkingDays} -> hpWorkingDays
|
|
Daily ds -> ds
|
|
scale precision x = case pt of
|
|
Hourly HourlyPeriod {hpAnnualHours, hpDailyHours} ->
|
|
fromRational (rnd $ x / fromIntegral hpAnnualHours)
|
|
* fromIntegral hpDailyHours
|
|
* n
|
|
Daily _ -> x * n / 365.25
|
|
where
|
|
rnd = roundPrecision precision
|
|
|
|
-- ASSUME start < end
|
|
workingDays :: [Weekday] -> Day -> Day -> Natural
|
|
workingDays wds start end = fromIntegral $ daysFull + daysTail
|
|
where
|
|
interval = diffDays end start
|
|
(nFull, nPart) = divMod interval 7
|
|
daysFull = fromIntegral (length wds') * nFull
|
|
daysTail = fromIntegral $ length $ takeWhile (< nPart) wds'
|
|
startDay = dayOfWeek start
|
|
wds' = L.sort $ (\x -> diff (fromWeekday x) startDay) <$> L.nub wds
|
|
diff a b = fromIntegral $ mod (fromEnum a - fromEnum b) 7
|
|
|
|
-- ASSUME days is a sorted list
|
|
foldDays
|
|
:: MonadInsertError m
|
|
=> (Day -> Day -> m a)
|
|
-> Day
|
|
-> [Day]
|
|
-> m [a]
|
|
foldDays f start days = case NE.nonEmpty days of
|
|
Nothing -> return []
|
|
Just ds
|
|
| any (start >) ds ->
|
|
throwError $
|
|
InsertException [PeriodError start $ minimum ds]
|
|
| otherwise ->
|
|
combineErrors $
|
|
snd $
|
|
L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days
|
|
|
|
isIncomeAcnt :: (MonadInsertError m, MonadFinance m) => AcntID -> m ()
|
|
isIncomeAcnt = checkAcntType IncomeT
|
|
|
|
isNotIncomeAcnt :: (MonadInsertError m, MonadFinance m) => AcntID -> m ()
|
|
isNotIncomeAcnt = checkAcntTypes (AssetT :| [EquityT, ExpenseT, LiabilityT])
|
|
|
|
checkAcntType
|
|
:: (MonadInsertError m, MonadFinance m)
|
|
=> AcntType
|
|
-> AcntID
|
|
-> m ()
|
|
checkAcntType t = checkAcntTypes (t :| [])
|
|
|
|
checkAcntTypes
|
|
:: (MonadInsertError m, MonadFinance m)
|
|
=> NE.NonEmpty AcntType
|
|
-> AcntID
|
|
-> m ()
|
|
checkAcntTypes ts i = void $ go =<< lookupAccountType i
|
|
where
|
|
go t
|
|
| t `L.elem` ts = return i
|
|
| otherwise = throwError $ InsertException [AccountError i ts]
|
|
|
|
flattenAllo :: SingleAllocation v -> [FlatAllocation v]
|
|
flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts
|
|
where
|
|
go Amount {amtValue, amtDesc} =
|
|
FlatAllocation
|
|
{ faCur = NoX alloCur
|
|
, faTo = alloTo
|
|
, faValue = amtValue
|
|
, faDesc = amtDesc
|
|
}
|
|
|
|
-- ASSUME allocations are sorted
|
|
selectAllos :: Day -> DaySpanAllocation v -> [FlatAllocation v]
|
|
selectAllos day Allocation {alloAmts, alloCur, alloTo} =
|
|
go <$> filter ((`inDaySpan` day) . amtWhen) alloAmts
|
|
where
|
|
go Amount {amtValue, amtDesc} =
|
|
FlatAllocation
|
|
{ faCur = NoX alloCur
|
|
, faTo = alloTo
|
|
, faValue = amtValue
|
|
, faDesc = amtDesc
|
|
}
|
|
|
|
allo2Trans
|
|
:: BudgetMeta
|
|
-> Day
|
|
-> TaggedAcnt
|
|
-> FlatAllocation Rational
|
|
-> UnbalancedTransfer
|
|
allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} =
|
|
FlatTransfer
|
|
{ ftMeta = meta
|
|
, ftWhen = day
|
|
, ftFrom = from
|
|
, ftCur = faCur
|
|
, ftTo = faTo
|
|
, ftValue = UnbalancedValue BTFixed faValue
|
|
, ftDesc = faDesc
|
|
}
|
|
|
|
allocatePre
|
|
:: Natural
|
|
-> Rational
|
|
-> [FlatAllocation PretaxValue]
|
|
-> (M.Map T.Text Rational, [FlatAllocation Rational])
|
|
allocatePre precision gross = L.mapAccumR go M.empty
|
|
where
|
|
go m f@FlatAllocation {faValue} =
|
|
let c = preCategory faValue
|
|
p = preValue faValue
|
|
v =
|
|
if prePercent faValue
|
|
then (roundPrecision 3 p / 100) * gross
|
|
else roundPrecision precision p
|
|
in (mapAdd_ c v m, f {faValue = v})
|
|
|
|
allocateTax
|
|
:: Natural
|
|
-> Rational
|
|
-> M.Map T.Text Rational
|
|
-> PeriodScaler
|
|
-> [FlatAllocation TaxValue]
|
|
-> [FlatAllocation Rational]
|
|
allocateTax precision gross preDeds f = fmap (fmap go)
|
|
where
|
|
go TaxValue {tvCategories, tvMethod} =
|
|
let agi = gross - sum (mapMaybe (`M.lookup` preDeds) tvCategories)
|
|
in case tvMethod of
|
|
TMPercent p ->
|
|
roundPrecision precision $
|
|
fromRational $
|
|
roundPrecision 3 p / 100 * agi
|
|
TMBracket TaxProgression {tpDeductible, tpBrackets} ->
|
|
let taxDed = roundPrecision precision $ f precision tpDeductible
|
|
in foldBracket f precision (agi - taxDed) tpBrackets
|
|
|
|
-- | Compute effective tax percentage of a bracket
|
|
-- The algorithm can be thought of in three phases:
|
|
-- 1. Find the highest tax bracket by looping backward until the AGI is less
|
|
-- than the bracket limit
|
|
-- 2. Computing the tax in the top bracket by subtracting the AGI from the
|
|
-- bracket limit and multiplying by the tax percentage.
|
|
-- 3. Adding all lower brackets, which are just the limit of the bracket less
|
|
-- the amount of the lower bracket times the percentage.
|
|
--
|
|
-- In reality, this can all be done with one loop, but it isn't clear these
|
|
-- three steps are implemented from this alone.
|
|
foldBracket :: PeriodScaler -> Natural -> Rational -> [TaxBracket] -> Rational
|
|
foldBracket f precision agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
|
|
where
|
|
go TaxBracket {tbLowerLimit, tbPercent} a@(acc, remain) =
|
|
let l = roundPrecision precision $ f precision tbLowerLimit
|
|
p = roundPrecision 3 tbPercent / 100
|
|
in if remain >= l then (acc + p * (remain - l), l) else a
|
|
|
|
allocatePost
|
|
:: Natural
|
|
-> Rational
|
|
-> [FlatAllocation PosttaxValue]
|
|
-> [FlatAllocation Rational]
|
|
allocatePost precision aftertax = fmap (fmap go)
|
|
where
|
|
go PosttaxValue {postValue, postPercent} =
|
|
let v = postValue
|
|
in if postPercent
|
|
then aftertax * roundPrecision 3 v / 100
|
|
else roundPrecision precision v
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Standalone Transfer
|
|
|
|
expandTransfers
|
|
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
|
=> CommitRId
|
|
-> T.Text
|
|
-> Maybe Interval
|
|
-> [BudgetTransfer]
|
|
-> m [UnbalancedTransfer]
|
|
expandTransfers key name localInterval ts = do
|
|
txs <-
|
|
fmap (L.sortOn ftWhen . concat) $
|
|
combineErrors $
|
|
fmap (expandTransfer key name) ts
|
|
case localInterval of
|
|
Nothing -> return txs
|
|
Just i -> do
|
|
bounds <- liftExcept $ resolveDaySpan i
|
|
return $ filter (inDaySpan bounds . ftWhen) txs
|
|
|
|
expandTransfer
|
|
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
|
=> CommitRId
|
|
-> T.Text
|
|
-> BudgetTransfer
|
|
-> m [UnbalancedTransfer]
|
|
expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = do
|
|
precision <- lookupCurrencyPrec $ initialCurrency transCurrency
|
|
fmap concat $ combineErrors $ fmap (go precision) transAmounts
|
|
where
|
|
go
|
|
precision
|
|
Amount
|
|
{ amtWhen = pat
|
|
, amtValue = BudgetTransferValue {btVal = v, btType = y}
|
|
, amtDesc = desc
|
|
} =
|
|
withDates pat $ \day -> do
|
|
let meta = BudgetMeta {bmCommit = key, bmName = name}
|
|
return
|
|
FlatTransfer
|
|
{ ftMeta = meta
|
|
, ftWhen = day
|
|
, ftCur = transCurrency
|
|
, ftFrom = transFrom
|
|
, ftTo = transTo
|
|
, ftValue = UnbalancedValue y $ roundPrecision precision v
|
|
, ftDesc = desc
|
|
}
|
|
|
|
withDates
|
|
:: (MonadSqlQuery m, MonadFinance m, MonadInsertError m)
|
|
=> DatePat
|
|
-> (Day -> m a)
|
|
-> m [a]
|
|
withDates dp f = do
|
|
bounds <- askDBState kmBudgetInterval
|
|
days <- liftExcept $ expandDatePat bounds dp
|
|
combineErrors $ fmap f days
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- shadow transfers
|
|
|
|
-- TODO this is going to be O(n*m), which might be a problem?
|
|
addShadowTransfers
|
|
:: CurrencyMap
|
|
-> [ShadowTransfer]
|
|
-> [UnbalancedTransfer]
|
|
-> InsertExcept [UnbalancedTransfer]
|
|
addShadowTransfers cm ms txs =
|
|
fmap catMaybes $
|
|
combineErrors $
|
|
fmap (uncurry (fromShadow cm)) $
|
|
[(t, m) | t <- txs, m <- ms]
|
|
|
|
fromShadow
|
|
:: CurrencyMap
|
|
-> UnbalancedTransfer
|
|
-> ShadowTransfer
|
|
-> InsertExcept (Maybe UnbalancedTransfer)
|
|
fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do
|
|
res <- shadowMatches (stMatch t) tx
|
|
v <- roundPrecisionCur (initialCurrency stCurrency) cm stRatio
|
|
return $
|
|
if not res
|
|
then Nothing
|
|
else
|
|
Just $
|
|
FlatTransfer
|
|
{ ftMeta = ftMeta tx
|
|
, ftWhen = ftWhen tx
|
|
, ftCur = stCurrency
|
|
, ftFrom = stFrom
|
|
, ftTo = stTo
|
|
, ftValue = UnbalancedValue stType $ v * cvValue (ftValue tx)
|
|
, ftDesc = stDesc
|
|
}
|
|
|
|
shadowMatches :: TransferMatcher -> UnbalancedTransfer -> InsertExcept Bool
|
|
shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do
|
|
valRes <- valMatches tmVal $ cvValue $ ftValue tx
|
|
return $
|
|
memberMaybe (taAcnt $ ftFrom tx) tmFrom
|
|
&& memberMaybe (taAcnt $ ftTo tx) tmTo
|
|
&& maybe True (`dateMatches` ftWhen tx) tmDate
|
|
&& valRes
|
|
where
|
|
memberMaybe x AcntSet {asList, asInclude} =
|
|
(if asInclude then id else not) $ x `elem` asList
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- random
|
|
|
|
initialCurrency :: BudgetCurrency -> CurID
|
|
initialCurrency (NoX c) = c
|
|
initialCurrency (X Exchange {xFromCur = c}) = c
|
|
|
|
alloAcnt :: Allocation w v -> AcntID
|
|
alloAcnt = taAcnt . alloTo
|
|
|
|
data UnbalancedValue = UnbalancedValue
|
|
{ cvType :: !BudgetTransferType
|
|
, cvValue :: !Rational
|
|
}
|
|
deriving (Show)
|
|
|
|
type UnbalancedTransfer = FlatTransfer UnbalancedValue
|
|
|
|
type BalancedTransfer = FlatTransfer Rational
|
|
|
|
data FlatTransfer v = FlatTransfer
|
|
{ ftFrom :: !TaggedAcnt
|
|
, ftTo :: !TaggedAcnt
|
|
, ftValue :: !v
|
|
, ftWhen :: !Day
|
|
, ftDesc :: !T.Text
|
|
, ftMeta :: !BudgetMeta
|
|
, ftCur :: !BudgetCurrency
|
|
}
|
|
deriving (Show)
|
|
|
|
data BudgetMeta = BudgetMeta
|
|
{ bmCommit :: !CommitRId
|
|
, bmName :: !T.Text
|
|
}
|
|
deriving (Show)
|
|
|
|
type IntAllocations =
|
|
( [DaySpanAllocation PretaxValue]
|
|
, [DaySpanAllocation TaxValue]
|
|
, [DaySpanAllocation PosttaxValue]
|
|
)
|
|
|
|
type DaySpanAllocation = Allocation DaySpan
|
|
|
|
type EntryPair = (KeyEntry, KeyEntry)
|
|
|
|
type PeriodScaler = Natural -> Double -> Double
|
|
|
|
data FlatAllocation v = FlatAllocation
|
|
{ faValue :: !v
|
|
, faDesc :: !T.Text
|
|
, faTo :: !TaggedAcnt
|
|
, faCur :: !BudgetCurrency
|
|
}
|
|
deriving (Functor, Show)
|