From b2fdc8d74ce2d93bf6cc708824aac1816848eb60 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Tue, 16 May 2023 23:12:29 -0400 Subject: [PATCH] FIX tax miscalculations --- lib/Internal/Insert.hs | 101 ++++++++++++++++++++++------------------- lib/Internal/Types.hs | 7 ++- 2 files changed, 61 insertions(+), 47 deletions(-) diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs index b5524e3..740d11b 100644 --- a/lib/Internal/Insert.hs +++ b/lib/Internal/Insert.hs @@ -135,7 +135,7 @@ foldDates dp start f = do insertBudget :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) => Budget - -> m [UnbalancedTransfer] + -> m () insertBudget b@Budget { bgtLabel @@ -146,7 +146,7 @@ insertBudget , bgtTax , bgtPosttax } = - whenHash CTBudget b [] $ \key -> do + whenHash CTBudget b () $ \key -> do intAllos <- combineError3 pre_ tax_ post_ (,,) let res1 = mapErrors (insertIncome key bgtLabel intAllos) bgtIncomes let res2 = expandTransfers key bgtLabel bgtTransfers @@ -154,7 +154,6 @@ insertBudget m <- askDBState kmCurrency shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs void $ mapErrors insertBudgetTx $ balanceTransfers $ txs ++ shadow - return $ shadow ++ txs where pre_ = sortAllos bgtPretax tax_ = sortAllos bgtTax @@ -172,16 +171,16 @@ type IntAllocations = -- TODO this should actually error if there is no ultimate end date? sortAllo :: MultiAllocation v -> InsertExcept (BoundAllocation v) sortAllo a@Allocation {alloAmts = as} = do - bs <- foldBounds (return []) $ L.sortOn amtWhen as + bs <- foldBounds [] $ L.sortOn amtWhen as return $ a {alloAmts = reverse bs} where - foldBounds acc [] = acc - foldBounds acc (x : xs) = - let res = case xs of - [] -> resolveBounds $ amtWhen x - (y : _) -> resolveBounds_ (intStart $ amtWhen y) $ amtWhen x - concatRes bs acc' = x {amtWhen = expandBounds bs} : acc' - in foldBounds (combineError res acc concatRes) xs + foldBounds acc [] = return acc + foldBounds acc (x : xs) = do + let start = amtWhen x + res <- case xs of + [] -> resolveBounds start + (y : _) -> resolveBounds_ (intStart $ amtWhen y) start + foldBounds (x {amtWhen = expandBounds res} : acc) xs -- TODO this is going to be O(n*m), which might be a problem? addShadowTransfers @@ -232,12 +231,12 @@ shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do (if asInclude then id else not) $ x `elem` asList balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer] -balanceTransfers ts = - snd $ L.mapAccumR go M.empty $ reverse $ L.sortOn cbtWhen ts +balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn cbtWhen where go bals f@FlatTransfer {cbtFrom, cbtTo, cbtValue = UnbalancedValue {cvValue, cvType}} = - let (bals', v) = mapAdd cbtTo x $ mapAdd_ cbtFrom (-x) bals - x = amtToMove v cvType cvValue + let balTo = M.findWithDefault 0 cbtTo bals + x = amtToMove balTo cvType cvValue + bals' = mapAdd_ cbtTo x $ mapAdd_ cbtFrom (-x) bals in (bals', f {cbtValue = x}) -- TODO might need to query signs to make this intuitive; as it is this will -- probably work, but for credit accounts I might need to supply a negative @@ -247,12 +246,7 @@ balanceTransfers ts = amtToMove bal BTTarget x = x - bal mapAdd_ :: (Ord k, Num v) => k -> v -> M.Map k v -> M.Map k v -mapAdd_ k v m = fst $ mapAdd k v m - -mapAdd :: (Ord k, Num v) => k -> v -> M.Map k v -> (M.Map k v, v) -mapAdd k v m = (new, M.findWithDefault (error "this should not happen") k new) - where - new = M.alter (maybe (Just v) (Just . (+ v))) k m +mapAdd_ k v = M.alter (maybe (Just v) (Just . (+ v))) k data BudgetMeta = BudgetMeta { bmCommit :: !CommitRId @@ -356,25 +350,14 @@ periodScaler -> Day -> Day -> InsertExcept PeriodScaler -periodScaler pt prev cur - | interval > 0 = return scale - -- TODO fix error here - | otherwise = throwError $ InsertException undefined +periodScaler pt prev cur = do + n <- workingDays wds prev cur + return $ scale (fromIntegral n) 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 + wds = case pt of + Hourly HourlyPeriod {hpWorkingDays} -> hpWorkingDays + Daily ds -> ds + scale n precision x = case pt of Hourly HourlyPeriod {hpAnnualHours, hpDailyHours} -> fromRational (rnd $ x / fromIntegral hpAnnualHours) * fromIntegral hpDailyHours @@ -383,6 +366,20 @@ periodScaler pt prev cur where rnd = roundPrecision precision +workingDays :: [Weekday] -> Day -> Day -> InsertExcept Natural +workingDays wds start end + | interval > 0 = + let (nFull, nPart) = divMod interval 7 + daysFull = fromIntegral (length wds') * nFull + daysTail = fromIntegral $ length $ takeWhile (< nPart) wds' + in return $ fromIntegral $ daysFull + daysTail + | otherwise = throwError $ InsertException undefined + where + interval = diffDays end start + startDay = dayOfWeek start + wds' = L.sort $ (\x -> diff (fromWeekday x) startDay) <$> L.nub wds + diff a b = fromIntegral $ mod (fromEnum a - fromEnum b) 7 + allocatePre :: Natural -> Rational @@ -428,7 +425,10 @@ allocateTax precision gross preDeds f = fmap (fmap go) go TaxValue {tvCategories, tvMethod} = let agi = gross - sum (mapMaybe (`M.lookup` preDeds) tvCategories) in case tvMethod of - TMPercent p -> roundPrecision 3 p / 100 * agi + TMPercent p -> + roundPrecision precision $ + fromRational $ + roundPrecision 3 p / 100 * agi TMBracket TaxProgression {tpDeductible, tpBrackets} -> let taxDed = roundPrecision precision $ f precision tpDeductible in foldBracket f precision (agi - taxDed) tpBrackets @@ -446,13 +446,24 @@ allocatePost precision aftertax = fmap (fmap go) then aftertax * roundPrecision 3 v / 100 else roundPrecision precision v +-- | 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. 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) = + go TaxBracket {tbLowerLimit, tbPercent} a@(acc, remain) = 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) + in if remain >= l then (acc + p * (remain - l), l) else a data FlatAllocation v = FlatAllocation { faValue :: !v @@ -460,7 +471,7 @@ data FlatAllocation v = FlatAllocation , faTo :: !TaggedAcnt , faCur :: !BudgetCurrency } - deriving (Functor) + deriving (Functor, Show) flattenAllo :: SingleAllocation v -> [FlatAllocation v] flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts @@ -476,9 +487,7 @@ flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts -- ASSUME allocations are sorted selectAllos :: Day -> BoundAllocation v -> [FlatAllocation v] selectAllos day Allocation {alloAmts, alloCur, alloTo} = - fmap go $ - takeWhile ((`inBounds` day) . amtWhen) $ - dropWhile ((day <) . fst . amtWhen) alloAmts + go <$> filter ((`inBounds` day) . amtWhen) alloAmts where go Amount {amtValue, amtDesc} = FlatAllocation diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs index 6058653..6b7fc77 100644 --- a/lib/Internal/Types.hs +++ b/lib/Internal/Types.hs @@ -293,7 +293,12 @@ fromPersistText what (PersistText t) = case readMaybe $ T.unpack t of fromPersistText what x = Left $ T.unwords ["error when deserializing", what, "; got", T.pack (show x)] -deriving instance Ord Interval +-- this is necessary since dhall will reverse the order when importing +instance Ord Interval where + compare + Interval {intStart = s0, intEnd = e0} + Interval {intStart = s1, intEnd = e1} = + compare (s0, e0) (s1, e1) data Transfer a c w v = Transfer { transFrom :: a