pwncash/lib/Internal/Budget.hs

415 lines
13 KiB
Haskell
Raw Normal View History

2023-07-01 13:12:50 -04:00
module Internal.Budget (readBudget) where
2023-05-07 20:29:33 -04:00
import Control.Monad.Except
import Data.Foldable
2023-05-29 17:33:59 -04:00
import Internal.Database
import Internal.Types.Main
import Internal.Utils
import RIO hiding (to)
2023-02-12 16:23:32 -05:00
import qualified RIO.List as L
import qualified RIO.Map as M
2023-02-12 21:52:41 -05:00
import qualified RIO.NonEmpty as NE
import qualified RIO.Text as T
import RIO.Time
2023-07-01 13:12:50 -04:00
readBudget
:: (MonadInsertError m, MonadFinance m)
2023-05-13 13:53:43 -04:00
=> Budget
-> m (Either CommitR [Tx CommitR])
2023-07-01 13:12:50 -04:00
readBudget
b@Budget
2023-04-30 23:28:16 -04:00
{ bgtLabel
, bgtIncomes
, bgtTransfers
, bgtShadowTransfers
, bgtPretax
, bgtTax
, bgtPosttax
2023-05-29 13:09:17 -04:00
, bgtInterval
} =
2023-07-01 13:12:50 -04:00
eitherHash CTBudget b return $ \key -> do
spanRes <- getSpan
case spanRes of
Nothing -> return []
Just budgetSpan -> do
(intAllos, _) <- combineError intAlloRes acntRes (,)
let res1 = mapErrors (readIncome key bgtLabel intAllos budgetSpan) bgtIncomes
let res2 = expandTransfers key bgtLabel budgetSpan bgtTransfers
txs <- combineError (concat <$> res1) res2 (++)
shadow <- addShadowTransfers bgtShadowTransfers txs
return $ txs ++ shadow
where
2023-05-29 17:14:01 -04:00
acntRes = mapErrors isNotIncomeAcnt alloAcnts
intAlloRes = combineError3 pre_ tax_ post_ (,,)
2023-05-07 20:29:33 -04:00
pre_ = sortAllos bgtPretax
tax_ = sortAllos bgtTax
post_ = sortAllos bgtPosttax
2023-05-29 17:14:01 -04:00
sortAllos = liftExcept . mapErrors sortAllo
alloAcnts =
(alloAcnt <$> bgtPretax)
++ (alloAcnt <$> bgtTax)
++ (alloAcnt <$> bgtPosttax)
getSpan = do
globalSpan <- askDBState kmBudgetInterval
case bgtInterval of
Nothing -> return $ Just globalSpan
Just bi -> do
localSpan <- liftExcept $ resolveDaySpan bi
return $ intersectDaySpan globalSpan localSpan
2023-05-29 15:56:15 -04:00
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
2023-05-29 15:56:15 -04:00
--------------------------------------------------------------------------------
-- Income
2023-02-12 16:52:42 -05:00
2023-05-29 17:06:38 -04:00
-- 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 :(
2023-07-01 13:12:50 -04:00
readIncome
2023-05-29 13:09:17 -04:00
:: (MonadInsertError m, MonadFinance m)
=> CommitR
-> T.Text
-> IntAllocations
-> DaySpan
-> Income
-> m [Tx CommitR]
2023-07-01 13:12:50 -04:00
readIncome
key
name
(intPre, intTax, intPost)
ds
2023-05-14 19:20:10 -04:00
Income
{ incWhen
, incCurrency
, incFrom = TaggedAcnt {taAcnt = srcAcnt, taTags = srcTags}
2023-05-14 19:20:10 -04:00
, incPretax
, incPosttax
, incTaxes
, incToBal = TaggedAcnt {taAcnt = destAcnt, taTags = destTags}
2023-05-14 19:20:10 -04:00
, incGross
, incPayPeriod
, incPriority
2023-05-29 17:06:38 -04:00
} =
combineErrorM
(combineError incRes nonIncRes (,))
(combineError cpRes dayRes (,))
$ \_ (cp, days) -> do
let gross = roundPrecisionCur cp incGross
foldDays (allocate cp gross) start days
where
incRes = isIncomeAcnt srcAcnt
2023-05-29 17:06:38 -04:00
nonIncRes =
mapErrors isNotIncomeAcnt $
destAcnt
2023-05-29 17:06:38 -04:00
: (alloAcnt <$> incPretax)
++ (alloAcnt <$> incTaxes)
++ (alloAcnt <$> incPosttax)
cpRes = lookupCurrency incCurrency
dayRes = liftExcept $ expandDatePat ds incWhen
2023-05-14 19:20:10 -04:00
start = fromGregorian' $ pStart incPayPeriod
pType' = pType incPayPeriod
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 cp gross prevDay day = do
2023-05-14 19:20:10 -04:00
scaler <- liftExcept $ periodScaler pType' prevDay day
let precision = cpPrec cp
let (preDeductions, pre) =
2023-05-04 21:48:21 -04:00
allocatePre precision gross $
flatPre ++ concatMap (selectAllos day) intPre
2023-06-30 23:54:39 -04:00
let tax =
2023-05-14 19:20:10 -04:00
allocateTax precision gross preDeductions scaler $
flatTax ++ concatMap (selectAllos day) intTax
2023-05-18 00:26:55 -04:00
aftertaxGross = gross - sumAllos (tax ++ pre)
2023-06-30 23:54:39 -04:00
let post =
2023-05-04 21:48:21 -04:00
allocatePost precision aftertaxGross $
flatPost ++ concatMap (selectAllos day) intPost
2023-06-30 23:54:39 -04:00
-- TODO double or rational here?
let src =
Entry
{ eAcnt = srcAcnt
, eValue = ()
, eComment = ""
, eTags = srcTags
}
let dest =
Entry
{ eAcnt = destAcnt
, eValue = ()
, eComment = "balance after deductions"
, eTags = destTags
}
let allos = allo2Trans <$> (pre ++ tax ++ post)
let primary =
EntrySet
{ esTotalValue = gross
, esCurrency = cp
, esFrom = HalfEntrySet {hesPrimary = src, hesOther = []}
, esTo = HalfEntrySet {hesPrimary = dest, hesOther = allos}
}
return $
Tx
{ txCommit = key
, txDate = day
, txPrimary = Left primary
, txOther = []
, txDescr = ""
, txBudget = name
, txPriority = incPriority
}
2023-05-14 19:20:10 -04:00
periodScaler
:: PeriodType
-> Day
-> Day
-> InsertExcept PeriodScaler
2023-05-29 16:36:59 -04:00
periodScaler pt prev cur = return scale
2023-05-14 19:20:10 -04:00
where
2023-05-29 16:36:59 -04:00
n = fromIntegral $ workingDays wds prev cur
2023-05-16 23:12:29 -04:00
wds = case pt of
Hourly HourlyPeriod {hpWorkingDays} -> hpWorkingDays
Daily ds -> ds
2023-05-29 16:36:59 -04:00
scale precision x = case pt of
2023-05-14 19:20:10 -04:00
Hourly HourlyPeriod {hpAnnualHours, hpDailyHours} ->
fromRational (rnd $ x / fromIntegral hpAnnualHours)
* fromIntegral hpDailyHours
* n
Daily _ -> x * n / 365.25
where
rnd = roundPrecision precision
2023-05-29 16:36:59 -04:00
-- ASSUME start < end
workingDays :: [Weekday] -> Day -> Day -> Natural
workingDays wds start end = fromIntegral $ daysFull + daysTail
2023-05-16 23:12:29 -04:00
where
interval = diffDays end start
2023-05-29 16:36:59 -04:00
(nFull, nPart) = divMod interval 7
daysFull = fromIntegral (length wds') * nFull
daysTail = fromIntegral $ length $ takeWhile (< nPart) wds'
2023-05-16 23:12:29 -04:00
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
2023-05-29 15:56:15 -04:00
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
2023-05-29 15:56:15 -04:00
2023-05-29 17:06:38 -04:00
isIncomeAcnt :: (MonadInsertError m, MonadFinance m) => AcntID -> m ()
isIncomeAcnt = checkAcntType IncomeT
isNotIncomeAcnt :: (MonadInsertError m, MonadFinance m) => AcntID -> m ()
isNotIncomeAcnt = checkAcntTypes (AssetT :| [EquityT, ExpenseT, LiabilityT])
2023-05-29 15:56:15 -04:00
checkAcntType
:: (MonadInsertError m, MonadFinance m)
=> AcntType
-> AcntID
2023-05-29 17:06:38 -04:00
-> m ()
2023-05-29 15:56:15 -04:00
checkAcntType t = checkAcntTypes (t :| [])
checkAcntTypes
:: (MonadInsertError m, MonadFinance m)
=> NE.NonEmpty AcntType
-> AcntID
2023-05-29 17:06:38 -04:00
-> m ()
checkAcntTypes ts i = void $ go =<< lookupAccountType i
where
2023-05-29 15:56:15 -04:00
go t
| t `L.elem` ts = return i
| otherwise = throwError $ InsertException [AccountError i ts]
flattenAllo :: SingleAllocation v -> [FlatAllocation v]
flattenAllo Allocation {alloAmts, alloTo} = fmap go alloAmts
2023-05-29 15:56:15 -04:00
where
go Amount {amtValue, amtDesc} =
FlatAllocation
{ faTo = alloTo
2023-05-29 15:56:15 -04:00
, faValue = amtValue
, faDesc = amtDesc
}
-- ASSUME allocations are sorted
selectAllos :: Day -> DaySpanAllocation v -> [FlatAllocation v]
selectAllos day Allocation {alloAmts, alloTo} =
2023-05-29 15:56:15 -04:00
go <$> filter ((`inDaySpan` day) . amtWhen) alloAmts
where
go Amount {amtValue, amtDesc} =
FlatAllocation
{ faTo = alloTo
2023-05-29 15:56:15 -04:00
, faValue = amtValue
, faDesc = amtDesc
}
allo2Trans :: FlatAllocation Rational -> Entry AcntID (LinkDeferred Rational) TagID
allo2Trans FlatAllocation {faValue, faTo = TaggedAcnt {taAcnt, taTags}, faDesc} =
Entry
{ eValue = LinkDeferred (EntryValue TFixed faValue)
, eComment = faDesc
, eAcnt = taAcnt
, eTags = taTags
}
2023-05-29 15:56:15 -04:00
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
2023-05-04 21:48:21 -04:00
:: Natural
-> Rational
-> M.Map T.Text Rational
2023-05-14 19:20:10 -04:00
-> PeriodScaler
-> [FlatAllocation TaxValue]
-> [FlatAllocation Rational]
2023-05-14 19:20:10 -04:00
allocateTax precision gross preDeds f = fmap (fmap go)
where
go TaxValue {tvCategories, tvMethod} =
2023-05-14 19:20:10 -04:00
let agi = gross - sum (mapMaybe (`M.lookup` preDeds) tvCategories)
in case tvMethod of
2023-05-16 23:12:29 -04:00
TMPercent p ->
roundPrecision precision $
fromRational $
roundPrecision 3 p / 100 * agi
2023-04-30 23:28:16 -04:00
TMBracket TaxProgression {tpDeductible, tpBrackets} ->
2023-05-14 19:20:10 -04:00
let taxDed = roundPrecision precision $ f precision tpDeductible
in foldBracket f precision (agi - taxDed) tpBrackets
2023-05-16 23:12:29 -04:00
-- | 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.
2023-05-14 19:20:10 -04:00
foldBracket :: PeriodScaler -> Natural -> Rational -> [TaxBracket] -> Rational
foldBracket f precision agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
where
2023-05-16 23:12:29 -04:00
go TaxBracket {tbLowerLimit, tbPercent} a@(acc, remain) =
2023-05-14 19:20:10 -04:00
let l = roundPrecision precision $ f precision tbLowerLimit
2023-05-08 00:12:01 -04:00
p = roundPrecision 3 tbPercent / 100
2023-05-16 23:12:29 -04:00
in if remain >= l then (acc + p * (remain - l), l) else a
2023-05-29 15:56:15 -04:00
allocatePost
:: Natural
-> Rational
-> [FlatAllocation PosttaxValue]
-> [FlatAllocation Rational]
allocatePost precision aftertax = fmap (fmap go)
where
2023-05-29 15:56:15 -04:00
go PosttaxValue {postValue, postPercent} =
let v = postValue
in if postPercent
then aftertax * roundPrecision 3 v / 100
else roundPrecision precision v
2022-12-11 17:51:11 -05:00
--------------------------------------------------------------------------------
2023-05-29 15:56:15 -04:00
-- shadow transfers
2023-05-13 13:53:43 -04:00
2023-05-29 15:56:15 -04:00
-- TODO this is going to be O(n*m), which might be a problem?
addShadowTransfers
2023-06-30 23:54:39 -04:00
:: (MonadInsertError m, MonadFinance m)
=> [ShadowTransfer]
-> [Tx CommitR]
-> m [Tx CommitR]
2023-07-01 13:12:50 -04:00
addShadowTransfers ms = mapErrors go
2023-06-30 23:54:39 -04:00
where
go tx = do
es <- catMaybes <$> mapErrors (fromShadow tx) ms
return $ tx {txOther = Right <$> es}
2022-12-11 17:51:11 -05:00
2023-05-29 15:56:15 -04:00
fromShadow
2023-06-30 23:54:39 -04:00
:: (MonadInsertError m, MonadFinance m)
=> Tx CommitR
2023-05-29 15:56:15 -04:00
-> ShadowTransfer
-> m (Maybe ShadowEntrySet)
2023-06-30 23:54:39 -04:00
fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} = do
res <- liftExcept $ shadowMatches stMatch tx
es <- entryPair stFrom stTo stCurrency stDesc stRatio ()
2023-06-30 23:54:39 -04:00
return $ if not res then Nothing else Just es
shadowMatches :: TransferMatcher -> Tx CommitR -> InsertExcept Bool
shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} Tx {txPrimary, txDate} = do
2023-06-30 23:54:39 -04:00
-- NOTE this will only match against the primary entry set since those
-- are what are guaranteed to exist from a transfer
valRes <- case txPrimary of
Left es -> valMatches tmVal $ esTotalValue es
Right _ -> return True
2023-05-29 15:56:15 -04:00
return $
memberMaybe fa tmFrom
&& memberMaybe ta tmTo
2023-06-30 23:54:39 -04:00
&& maybe True (`dateMatches` txDate) tmDate
&& valRes
2022-12-11 17:51:11 -05:00
where
fa = either getAcntFrom getAcntFrom txPrimary
ta = either getAcntTo getAcntTo txPrimary
getAcntFrom = getAcnt esFrom
getAcntTo = getAcnt esTo
getAcnt f = eAcnt . hesPrimary . f
2023-05-29 15:56:15 -04:00
memberMaybe x AcntSet {asList, asInclude} =
(if asInclude then id else not) $ x `elem` asList
2022-12-11 17:51:11 -05:00
2023-05-29 15:56:15 -04:00
--------------------------------------------------------------------------------
-- random
2023-01-28 22:55:07 -05:00
2023-05-29 17:06:38 -04:00
alloAcnt :: Allocation w v -> AcntID
alloAcnt = taAcnt . alloTo
2023-05-29 15:56:15 -04:00
type IntAllocations =
( [DaySpanAllocation PretaxValue]
, [DaySpanAllocation TaxValue]
, [DaySpanAllocation PosttaxValue]
)
2023-02-12 16:52:42 -05:00
2023-05-29 15:56:15 -04:00
type DaySpanAllocation = Allocation DaySpan
2023-05-04 21:48:21 -04:00
2023-05-29 15:56:15 -04:00
type PeriodScaler = Natural -> Double -> Double
2023-05-07 20:29:33 -04:00
2023-05-29 15:56:15 -04:00
data FlatAllocation v = FlatAllocation
{ faValue :: !v
, faDesc :: !T.Text
, faTo :: !TaggedAcnt
}
deriving (Functor, Show)