pwncash/lib/Internal/Budget.hs

396 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
2023-07-08 00:52:40 -04:00
import Data.Decimal hiding (allocate)
import Data.Foldable
2023-07-13 23:31:27 -04:00
import Data.Hashable
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-13 23:31:27 -04:00
readBudget :: (MonadInsertError m, MonadFinance m) => Budget -> m [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-13 23:31:27 -04:00
do
spanRes <- getSpan
case spanRes of
Nothing -> return []
Just budgetSpan -> do
(intAllos, _) <- combineError intAlloRes acntRes (,)
2023-07-13 23:31:27 -04:00
let res1 = mapErrors (readIncome c bgtLabel intAllos budgetSpan) bgtIncomes
let res2 = expandTransfers c bgtLabel budgetSpan bgtTransfers
txs <- combineError (concat <$> res1) res2 (++)
shadow <- addShadowTransfers bgtShadowTransfers txs
return $ txs ++ shadow
where
2023-07-13 23:31:27 -04:00
c = CommitR (hash b) CTBudget
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
2023-07-13 23:31:27 -04:00
globalSpan <- askDBState csBudgetScope
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
2023-07-08 00:52:40 -04:00
let gross = realFracToDecimal (cpPrec 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
2023-07-13 23:31:27 -04:00
entry0 a c ts = Entry {eAcnt = a, eValue = (), eComment = c, eTags = ts}
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-07-13 23:31:27 -04:00
let src = entry0 srcAcnt "gross income" srcTags
let dest = entry0 destAcnt "balance after deductions" destTags
let allos = allo2Trans <$> (pre ++ tax ++ post)
let primary =
EntrySet
{ esTotalValue = gross
2023-07-08 00:52:40 -04:00
, esCurrency = cpID 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-07-08 00:52:40 -04:00
n = workingDays wds prev cur
2023-05-16 23:12:29 -04:00
wds = case pt of
Hourly HourlyPeriod {hpWorkingDays} -> hpWorkingDays
Daily ds -> ds
2023-07-08 00:52:40 -04:00
scale prec x = case pt of
2023-05-14 19:20:10 -04:00
Hourly HourlyPeriod {hpAnnualHours, hpDailyHours} ->
2023-07-08 00:52:40 -04:00
realFracToDecimal prec (x / fromIntegral hpAnnualHours)
2023-05-14 19:20:10 -04:00
* fromIntegral hpDailyHours
2023-07-08 00:52:40 -04:00
* fromIntegral n
Daily _ -> realFracToDecimal prec (x * fromIntegral n / 365.25)
2023-05-14 19:20:10 -04:00
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
}
2023-07-08 00:52:40 -04:00
allo2Trans :: FlatAllocation Decimal -> Entry AcntID LinkDeferred TagID
allo2Trans FlatAllocation {faValue, faTo = TaggedAcnt {taAcnt, taTags}, faDesc} =
Entry
2023-07-08 00:52:40 -04:00
{ eValue = LinkDeferred (EntryFixed faValue)
, eComment = faDesc
, eAcnt = taAcnt
, eTags = taTags
}
2023-05-29 15:56:15 -04:00
allocatePre
2023-07-08 00:52:40 -04:00
:: Precision
-> Decimal
2023-05-29 15:56:15 -04:00
-> [FlatAllocation PretaxValue]
2023-07-08 00:52:40 -04:00
-> (M.Map T.Text Decimal, [FlatAllocation Decimal])
2023-05-29 15:56:15 -04:00
allocatePre precision gross = L.mapAccumR go M.empty
where
2023-07-08 00:52:40 -04:00
go m f@FlatAllocation {faValue = PretaxValue {preCategory, preValue, prePercent}} =
let v =
if prePercent
then gross *. (preValue / 100)
else realFracToDecimal precision preValue
in (mapAdd_ preCategory v m, f {faValue = v})
2023-05-29 15:56:15 -04:00
allocateTax
2023-07-08 00:52:40 -04:00
:: Precision
-> Decimal
-> M.Map T.Text Decimal
2023-05-14 19:20:10 -04:00
-> PeriodScaler
-> [FlatAllocation TaxValue]
2023-07-08 00:52:40 -04:00
-> [FlatAllocation Decimal]
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-07-08 00:52:40 -04:00
TMPercent p -> agi *. p / 100
2023-04-30 23:28:16 -04:00
TMBracket TaxProgression {tpDeductible, tpBrackets} ->
2023-07-08 00:52:40 -04:00
let taxDed = f precision tpDeductible
2023-05-14 19:20:10 -04:00
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-07-08 00:52:40 -04:00
foldBracket :: PeriodScaler -> Precision -> Decimal -> [TaxBracket] -> Decimal
foldBracket f prec 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-07-08 00:52:40 -04:00
let l = f prec tbLowerLimit
in if remain >= l
then (acc + (remain - l) *. (tbPercent / 100), l)
else a
2023-05-29 15:56:15 -04:00
allocatePost
2023-07-08 00:52:40 -04:00
:: Precision
-> Decimal
2023-05-29 15:56:15 -04:00
-> [FlatAllocation PosttaxValue]
2023-07-08 00:52:40 -04:00
-> [FlatAllocation Decimal]
allocatePost prec aftertax = fmap (fmap go)
where
2023-07-08 00:52:40 -04:00
go PosttaxValue {postValue, postPercent}
| postPercent = aftertax *. (postValue / 100)
| otherwise = realFracToDecimal prec postValue
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-07-13 23:31:27 -04:00
fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} =
combineErrorM curRes shaRes $ \cur sha -> do
let es = entryPair stFrom stTo cur stDesc stRatio ()
return $ if not sha then Nothing else Just es
where
curRes = lookupCurrencyKey stCurrency
shaRes = liftExcept $ shadowMatches stMatch tx
2023-06-30 23:54:39 -04:00
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
2023-07-08 00:52:40 -04:00
Left es -> valMatches tmVal $ toRational $ 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-07-08 00:52:40 -04:00
type PeriodScaler = Precision -> Double -> Decimal
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)