From 5e2e8d8acf978b69d8d20ae58dd9f67d3febd504 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sun, 14 May 2023 19:20:10 -0400 Subject: [PATCH] ENH scale taxes by pay period length --- dhall/Types.dhall | 55 +++++++++++++++++++++++++++ lib/Internal/Insert.hs | 85 ++++++++++++++++++++++++++++++++++++------ lib/Internal/Types.hs | 14 +++++++ lib/Internal/Utils.hs | 21 ++++++++++- 4 files changed, 163 insertions(+), 12 deletions(-) diff --git a/dhall/Types.dhall b/dhall/Types.dhall index dbbde81..063c7c2 100644 --- a/dhall/Types.dhall +++ b/dhall/Types.dhall @@ -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 } diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs index d9b2bfd..b5524e3 100644 --- a/lib/Internal/Insert.hs +++ b/lib/Internal/Insert.hs @@ -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) diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs index f5e7be5..6058653 100644 --- a/lib/Internal/Types.hs +++ b/lib/Internal/Types.hs @@ -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] diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index f1dee17..76db251 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -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) ->