FIX tax miscalculations

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
+    wds = 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
+    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

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