ENH scale taxes by pay period length

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
     }

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 <- foldDates incWhen start (allocate precision gross)
-    res <- withDates incWhen (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 :: PeriodScaler -> Natural -> Rational -> [TaxBracket] -> Rational
-foldBracket precision agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
+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)
 

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]

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) ->