ENH scale taxes by pay period length
This commit is contained in:
parent
397a78ddfb
commit
5e2e8d8acf
|
|
@ -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
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -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) ->
|
||||
|
|
|
|||
Loading…
Reference in New Issue