ENH scale taxes by pay period length

This commit is contained in:
Nathan Dwarshuis 2023-05-14 19:20:10 -04:00
parent 397a78ddfb
commit 5e2e8d8acf
4 changed files with 163 additions and 12 deletions

View File

@ -787,6 +787,52 @@ let MultiAllocation =
-}
Allocation Interval
let HourlyPeriod =
{-
Definition for a pay period denominated in hours
-}
{ hpAnnualHours :
{-
Number of hours in one year
-}
Natural
, hpDailyHours :
{-
Number of hours in one working day
-}
Natural
, hpWorkingDays :
{-
Days which count as working days
-}
List Weekday
}
let PeriodType =
{-
Type of pay period.
Hourly: pay period is denominated in hours
Daily: pay period is denominated in working days (specified in a list)
-}
< Hourly : HourlyPeriod | Daily : List Weekday >
let Period =
{-
Definition of a pay period
-} { pType :
{-
Type of pay period
-}
PeriodType
, pStart :
{-
Start date of the pay period. Must occur before first payment
in this income stream is dispersed.
-}
Gregorian
}
let Income =
{-
Means to compute an income stream and how to allocate it
@ -807,6 +853,12 @@ let Income =
The dates on which the income stream is distributed.
-}
DatePat
, incPayPeriod :
{-
Defines the period of time over which this income was earned
(mostly used for taxes)
-}
Period
, incPretax : List (SingleAllocation PretaxValue)
, incTaxes : List (SingleAllocation TaxValue)
, incPosttax : List (SingleAllocation PosttaxValue)
@ -1029,4 +1081,7 @@ in { CurID
, HistTransfer
, SingleAllocation
, MultiAllocation
, HourlyPeriod
, Period
, PeriodType
}

View File

@ -105,6 +105,19 @@ withDates dp f = do
days <- liftExcept $ expandDatePat bounds dp
combineErrors $ fmap f days
foldDates
:: (MonadSqlQuery m, MonadFinance m, MonadInsertError m)
=> DatePat
-> Day
-> (Day -> Day -> m a)
-> m [a]
foldDates dp start f = do
bounds <- askDBState kmBudgetInterval
days <- liftExcept $ expandDatePat bounds dp
combineErrors $
snd $
L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days
--------------------------------------------------------------------------------
-- budget
@ -279,29 +292,42 @@ insertIncome
key
name
(intPre, intTax, intPost)
Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal, incGross} = do
Income
{ incWhen
, incCurrency
, incFrom
, incPretax
, incPosttax
, incTaxes
, incToBal
, incGross
, incPayPeriod
} = do
-- TODO check that the other accounts are not income somewhere here
_ <- checkAcntType IncomeT $ taAcnt incFrom
precision <- lookupCurrencyPrec incCurrency
let gross = roundPrecision precision incGross
-- 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 :(
let gross = roundPrecision precision incGross
res <- withDates incWhen (allocate precision gross)
res <- foldDates incWhen start (allocate precision gross)
return $ concat res
where
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 day =
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 $
allocateTax precision gross preDeductions scaler $
flatTax ++ concatMap (selectAllos day) intTax
aftertaxGross = sumAllos $ tax ++ pre
post =
@ -322,6 +348,41 @@ insertIncome
then throwError $ InsertException [IncomeError day name balance]
else return (bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post))
type PeriodScaler = Natural -> Double -> Double
-- TODO we probably don't need to check for 1/0 each time
periodScaler
:: PeriodType
-> Day
-> Day
-> InsertExcept PeriodScaler
periodScaler pt prev cur
| interval > 0 = return scale
-- TODO fix error here
| otherwise = throwError $ InsertException undefined
where
interval = diffDays cur prev
startDay = dayOfWeek prev
days = L.sort $
fmap (diff startDay . fromWeekday) $
L.nub $ case pt of
Hourly HourlyPeriod {hpWorkingDays} -> hpWorkingDays
Daily ds -> ds
diff a b = fromIntegral $ mod (fromEnum a - fromEnum b) 7
n =
let (nFull, nPart) = divMod interval 7
daysFull = fromIntegral (length days) * nFull
daysTail = fromIntegral $ length $ takeWhile (< nPart) days
in fromIntegral $ daysFull + daysTail
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
allocatePre
:: Natural
-> Rational
@ -359,16 +420,18 @@ allocateTax
:: Natural
-> Rational
-> M.Map T.Text Rational
-> PeriodScaler
-> [FlatAllocation TaxValue]
-> [FlatAllocation Rational]
allocateTax precision gross deds = fmap (fmap go)
allocateTax precision gross preDeds f = fmap (fmap go)
where
go TaxValue {tvCategories, tvMethod} =
let agi = gross - sum (mapMaybe (`M.lookup` deds) tvCategories)
let agi = gross - sum (mapMaybe (`M.lookup` preDeds) tvCategories)
in case tvMethod of
TMPercent p -> roundPrecision 3 p / 100 * agi
TMBracket TaxProgression {tpDeductible, tpBrackets} ->
foldBracket precision (agi - roundPrecision precision tpDeductible) tpBrackets
let taxDed = roundPrecision precision $ f precision tpDeductible
in foldBracket f precision (agi - taxDed) tpBrackets
allocatePost
:: Natural
@ -383,11 +446,11 @@ allocatePost precision aftertax = fmap (fmap go)
then aftertax * roundPrecision 3 v / 100
else roundPrecision precision v
foldBracket :: Natural -> Rational -> [TaxBracket] -> Rational
foldBracket precision agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
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} (acc, remain) =
let l = roundPrecision precision tbLowerLimit
let l = roundPrecision precision $ f precision tbLowerLimit
p = roundPrecision 3 tbPercent / 100
in if remain < l then (acc + p * (remain - l), l) else (acc, remain)

View File

@ -41,6 +41,7 @@ makeHaskellTypesWith
, MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
, MultipleConstructors "BudgetTransferType" "(./dhall/Types.dhall).BudgetTransferType"
, MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod"
, MultipleConstructors "PeriodType" "(./dhall/Types.dhall).PeriodType"
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
, SingleConstructor "Tag" "Tag" "(./dhall/Types.dhall).Tag"
, SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt"
@ -66,6 +67,8 @@ makeHaskellTypesWith
, SingleConstructor "TaxValue" "TaxValue" "(./dhall/Types.dhall).TaxValue"
, SingleConstructor "PosttaxValue" "PosttaxValue" "(./dhall/Types.dhall).PosttaxValue"
, SingleConstructor "BudgetTransferValue" "BudgetTransferValue" "(./dhall/Types.dhall).BudgetTransferValue"
, SingleConstructor "Period" "Period" "(./dhall/Types.dhall).Period"
, SingleConstructor "HourlyPeriod" "HourlyPeriod" "(./dhall/Types.dhall).HourlyPeriod"
-- , SingleConstructor "ToTx" "ToTx" "(./dhall/Types.dhall).ToTx"
-- , SingleConstructor "FieldMatcher" "FieldMatcher" "(./dhall/Types.dhall).FieldMatcher_"
-- , SingleConstructor "Match" "Match" "(./dhall/Types.dhall).Match_"
@ -110,6 +113,9 @@ deriveProduct
, "PosttaxValue"
, "BudgetTransferValue"
, "BudgetTransferType"
, "Period"
, "PeriodType"
, "HourlyPeriod"
]
-------------------------------------------------------------------------------
@ -229,8 +235,15 @@ data Income = Income
, incPosttax :: [SingleAllocation PosttaxValue]
, incFrom :: TaggedAcnt
, incToBal :: TaggedAcnt
, incPayPeriod :: !Period
}
deriving instance Hashable HourlyPeriod
deriving instance Hashable PeriodType
deriving instance Hashable Period
deriving instance Hashable Income
deriving instance (Ord w, Ord v) => Ord (Amount w v)
@ -747,6 +760,7 @@ data InsertError
| PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
| BoundsError !Gregorian !(Maybe Gregorian)
| StatementError ![TxRecord] ![MatchRe]
| PeriodError !Day !Day
deriving (Show)
newtype InsertException = InsertException [InsertError]

View File

@ -1,5 +1,6 @@
module Internal.Utils
( compareDate
, fromWeekday
, inBounds
, expandBounds
, fmtRational
@ -77,6 +78,16 @@ import Text.Regex.TDFA.Text
--------------------------------------------------------------------------------
-- dates
-- | Lame weekday converter since day of weeks aren't in dhall (yet)
fromWeekday :: Weekday -> DayOfWeek
fromWeekday Mon = Monday
fromWeekday Tue = Tuesday
fromWeekday Wed = Wednesday
fromWeekday Thu = Thursday
fromWeekday Fri = Friday
fromWeekday Sat = Saturday
fromWeekday Sun = Sunday
-- | find the next date
-- this is meant to go in a very tight loop and be very fast (hence no
-- complex date functions, most of which heavily use 'mod' and friends)
@ -500,7 +511,15 @@ showError other = case other of
, "exceed total on day"
, showT day
, "where balance is"
, showT balance
, showT (fromRational balance :: Double)
]
]
(PeriodError start next) ->
[ T.unwords
[ "First pay period on "
, singleQuote $ showT start
, "must start before first income payment on "
, singleQuote $ showT next
]
]
(BalanceError t cur rss) ->