ENH use intervals to define allocations

dhall/Types.dhall

@@ -195,9 +195,10 @@ let Amount = { amtValue : Decimal, amtDesc : Text }
 
 let AmountType = < FixedAmt | Percent | Target >
 
-let TimeAmount = { taWhen : DatePat, taAmt : Amount, taAmtType : AmountType }
+let TimeAmount =
+      \(t : Type) -> { taWhen : t, taAmt : Amount, taAmtType : AmountType }
 
-let Tax = { taxAcnt : AcntID, taxValue : Decimal }
+let DateAmount = TimeAmount DatePat
 
 let Exchange =
       { xFromCur : CurID, xToCur : CurID, xAcnt : AcntID, xRate : Decimal }
@@ -206,27 +207,32 @@ let BudgetCurrency = < NoX : CurID | X : Exchange >
 
 let TaggedAcnt = { taAcnt : AcntID, taTags : List TagID }
 
-let Allocation =
+let Allocation_ =
-      { alloTo : TaggedAcnt, alloAmts : List Amount, alloCur : BudgetCurrency }
+      \(t : Type) ->
+        { alloTo : TaggedAcnt, alloAmts : List t, alloCur : BudgetCurrency }
+
+let Allocation = Allocation_ Amount
+
+let IntervalAllocation = Allocation_ (TimeAmount Interval)
 
 let Income =
       { incGross : Decimal
       , incCurrency : CurID
       , incWhen : DatePat
+      , incPretax : List Allocation
+      , incTaxes : List Allocation
+      , incPosttax : List Allocation
       , incFrom :
           {- this must be an income AcntID, and is the only place income
           accounts may be specified in the entire budget -}
           TaggedAcnt
-      , incPretax : List Allocation
-      , incTaxes : List Tax
-      , incPosttax : List Allocation
       , incToBal : TaggedAcnt
       }
 
 let Transfer =
       { transFrom : TaggedAcnt
       , transTo : TaggedAcnt
-      , transAmounts : List TimeAmount
+      , transAmounts : List DateAmount
       , transCurrency : BudgetCurrency
       }
 
@@ -261,7 +267,10 @@ let ShadowTransfer =
 
 let Budget =
       { budgetLabel : Text
-      , income : List Income
+      , incomes : List Income
+      , pretax : List IntervalAllocation
+      , tax : List IntervalAllocation
+      , posttax : List IntervalAllocation
       , transfers : List Transfer
       , shadowTransfers : List ShadowTransfer
       }
@@ -306,8 +315,8 @@ in  { CurID
     , Transfer
     , Income
     , Budget
-    , Tax
     , Allocation
+    , IntervalAllocation
     , Amount
     , TimeAmount
     , AmountType

lib/Internal/Insert.hs

@@ -119,15 +119,52 @@ withDates dp f = do
 -- 5. insert all transactions
 
 insertBudget :: MonadFinance m => Budget -> SqlPersistT m [InsertError]
-insertBudget b@(Budget {budgetLabel = name, income = is, transfers = es, shadowTransfers = ss}) =
+insertBudget
+  b@( Budget
+        { budgetLabel
+        , incomes
+        , transfers
+        , shadowTransfers
+        , pretax
+        , tax
+        , posttax
+        }
+      ) =
     whenHash CTBudget b [] $ \key -> do
-    res1 <- mapM (insertIncome key name) is
+      unlessLefts intAllos $ \intAllos_ -> do
-    res2 <- expandTransfers key name es
+        res1 <- mapM (insertIncome key budgetLabel intAllos_) incomes
+        res2 <- expandTransfers key budgetLabel transfers
         unlessLefts (concatEithers2 (fmap concat $ concatEithersL res1) res2 (++)) $
           \txs -> do
-        unlessLefts (addShadowTransfers ss txs) $ \shadow -> do
+            unlessLefts (addShadowTransfers shadowTransfers txs) $ \shadow -> do
               let bals = balanceTransfers $ txs ++ shadow
               concat <$> mapM insertBudgetTx bals
+    where
+      intAllos =
+        let pre_ = sortAllos pretax
+            tax_ = sortAllos tax
+            post_ = sortAllos posttax
+         in concatEithers3 pre_ tax_ post_ (,,)
+      sortAllos = concatEithersL . fmap sortAllo
+
+type BoundAllocation = Allocation_ (TimeAmount (Day, Day))
+
+type IntAllocations = ([BoundAllocation], [BoundAllocation], [BoundAllocation])
+
+-- TODO this should actually error if there is no ultimate end date
+sortAllo :: IntervalAllocation -> EitherErrs BoundAllocation
+sortAllo a@Allocation_ {alloAmts = as} = do
+  bs <- fmap reverse <$> foldBounds (Right []) $ L.sort as
+  return $ a {alloAmts = L.sort bs}
+  where
+    foldBounds acc [] = acc
+    foldBounds acc (x : xs) =
+      let res = fmap (fmap expandBounds) $ case xs of
+            [] -> mapM resolveBounds x
+            (y : _) ->
+              let end = intStart $ taWhen y
+               in mapM (resolveBounds_ end) x
+       in foldBounds (concatEithers2 (plural res) acc (:)) xs
 
 -- TODO this is going to be O(n*m), which might be a problem?
 addShadowTransfers :: [ShadowTransfer] -> [BudgetTxType] -> EitherErrs [BudgetTxType]
@@ -219,12 +256,18 @@ data BudgetTxType = BudgetTxType
   , bttTx :: !BudgetTx
   }
 
-insertIncome :: MonadFinance m => CommitRId -> T.Text -> Income -> SqlPersistT m (EitherErrs [BudgetTxType])
+insertIncome
+  :: MonadFinance m
+  => CommitRId
+  -> T.Text
+  -> IntAllocations
+  -> Income
+  -> SqlPersistT m (EitherErrs [BudgetTxType])
 insertIncome
   key
   name
+  (intPre, intTax, intPost)
   i@Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal} = do
-    -- whenHash CTIncome i (Right []) $ \c -> do
     let meta = BudgetMeta key (NoX incCurrency) name
     let balRes = balanceIncome i
     fromRes <- lift $ checkAcntType IncomeT $ taAcnt incFrom
@@ -233,13 +276,15 @@ insertIncome
       -- TODO this hole seems sloppy...
       Right (balance, _) ->
         fmap (fmap (concat . concat)) $
+          -- 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 :(
           withDates incWhen $ \day -> do
             let fromAllos = fmap concat . mapM (lift . fromAllo day meta incFrom)
-            pre <- fromAllos incPretax
+            pre <- fromAllos $ incPretax ++ mapMaybe (selectAllos day) intPre
-            tax <-
+            -- TODO ensure these are all expense accounts
-              concatEitherL
+            tax <- fromAllos $ incTaxes ++ mapMaybe (selectAllos day) intTax
-                <$> mapM (lift . fromTax day meta (taAcnt incFrom)) incTaxes
+            post <- fromAllos $ incPosttax ++ mapMaybe (selectAllos day) intPost
-            post <- fromAllos incPosttax
             let bal =
                   BudgetTxType
                     { bttTx =
@@ -253,7 +298,19 @@ insertIncome
                           }
                     , bttType = FixedAmt
                     }
-            return $ concatEithersL [Right [bal], tax, Right pre, Right post]
+            return $ concatEithersL [Right [bal], Right tax, Right pre, Right post]
+
+-- ASSUME allocations are sorted
+selectAllos :: Day -> BoundAllocation -> Maybe Allocation
+selectAllos day a@Allocation_ {alloAmts = as} = case select [] as of
+  [] -> Nothing
+  xs -> Just $ a {alloAmts = xs}
+  where
+    select acc [] = acc
+    select acc (x : xs)
+      | (fst $ taWhen x) < day = select acc xs
+      | inBounds (taWhen x) day = select (taAmt x : acc) xs
+      | otherwise = acc
 
 fromAllo
   :: MonadFinance m
@@ -262,7 +319,7 @@ fromAllo
   -> TaggedAcnt
   -> Allocation
   -> m [BudgetTxType]
-fromAllo day meta from Allocation {alloTo, alloAmts} = do
+fromAllo day meta from Allocation_ {alloTo, alloAmts} = do
   -- TODO this is going to be repeated a zillion times (might matter)
   -- res <- expandTarget alloPath
   return $ fmap toBT alloAmts
@@ -281,31 +338,31 @@ fromAllo day meta from Allocation {alloTo, alloAmts} = do
         , bttType = FixedAmt
         }
 
--- TODO maybe allow tags here?
+-- -- TODO maybe allow tags here?
-fromTax
+-- fromTax
-  :: MonadFinance m
+--   :: MonadFinance m
-  => Day
+--   => Day
-  -> BudgetMeta
+--   -> BudgetMeta
-  -> AcntID
+--   -> AcntID
-  -> Tax
+--   -> Tax
-  -> m (EitherErr BudgetTxType)
+--   -> m (EitherErr BudgetTxType)
-fromTax day meta from Tax {taxAcnt = to, taxValue = v} = do
+-- fromTax day meta from Tax {taxAcnt = to, taxValue = v} = do
-  res <- checkAcntType ExpenseT to
+--   res <- checkAcntType ExpenseT to
-  return $ fmap go res
+--   return $ fmap go res
-  where
+--   where
-    go to_ =
+--     go to_ =
-      BudgetTxType
+--       BudgetTxType
-        { bttTx =
+--         { bttTx =
-            BudgetTx
+--             BudgetTx
-              { btFrom = TaggedAcnt from []
+--               { btFrom = TaggedAcnt from []
-              , btWhen = day
+--               , btWhen = day
-              , btTo = TaggedAcnt to_ []
+--               , btTo = TaggedAcnt to_ []
-              , btValue = dec2Rat v
+--               , btValue = dec2Rat v
-              , btDesc = ""
+--               , btDesc = ""
-              , btMeta = meta
+--               , btMeta = meta
-              }
+--               }
-        , bttType = FixedAmt
+--         , bttType = FixedAmt
-        }
+--         }
 
 balanceIncome :: Income -> EitherErr Rational
 balanceIncome
@@ -319,13 +376,13 @@ balanceIncome
     | bal < 0 = Left $ IncomeError dp
     | otherwise = Right bal
     where
-      bal = dec2Rat g - sum (sumAllocation <$> pre ++ post) - sumTaxes tax
+      bal = dec2Rat g - sum (sumAllocation <$> pre ++ tax ++ post)
 
 sumAllocation :: Allocation -> Rational
 sumAllocation = sum . fmap (dec2Rat . amtValue) . alloAmts
 
-sumTaxes :: [Tax] -> Rational
+-- sumTaxes :: [Tax] -> Rational
-sumTaxes = sum . fmap (dec2Rat . taxValue)
+-- sumTaxes = sum . fmap (dec2Rat . taxValue)
 
 expandTransfers
   :: MonadFinance m
@@ -341,7 +398,7 @@ expandTransfer :: MonadFinance m => CommitRId -> T.Text -> Transfer -> SqlPersis
 expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} =
   -- whenHash CTExpense t (Right []) $ \key ->
   fmap (fmap concat . concatEithersL) $
-    forM transAmounts $ \(TimeAmount (Amount desc v) atype pat) -> do
+    forM transAmounts $ \(TimeAmount pat (Amount desc v) atype) -> do
       withDates pat $ \day ->
         let meta =
               BudgetMeta

lib/Internal/Types.hs

@@ -49,14 +49,12 @@ makeHaskellTypesWith
   , SingleConstructor "Decimal" "D" "(./dhall/Types.dhall).Decimal"
   , SingleConstructor "MatchVal" "MatchVal" "(./dhall/Types.dhall).MatchVal.Type"
   , SingleConstructor "Manual" "Manual" "(./dhall/Types.dhall).Manual"
-  , SingleConstructor "Tax" "Tax" "(./dhall/Types.dhall).Tax"
   , SingleConstructor "Amount" "Amount" "(./dhall/Types.dhall).Amount"
-  , SingleConstructor "TimeAmount" "TimeAmount" "(./dhall/Types.dhall).TimeAmount"
+  , -- , SingleConstructor "TimeAmount" "TimeAmount" "(./dhall/Types.dhall).TimeAmount"
-  , SingleConstructor "Allocation" "Allocation" "(./dhall/Types.dhall).Allocation"
+    -- , SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income"
-  , SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income"
+    -- , SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget"
-  , SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget"
+    -- , SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
-  , SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
+    SingleConstructor "Exchange" "Exchange" "(./dhall/Types.dhall).Exchange"
-  , SingleConstructor "Exchange" "Exchange" "(./dhall/Types.dhall).Exchange"
   , SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt"
   , SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type"
   , SingleConstructor "ShadowMatch" "ShadowMatch" "(./dhall/Types.dhall).ShadowMatch.Type"
@@ -146,6 +144,12 @@ instance Ord GregorianM where
     GregorianM {gmYear = y, gmMonth = m}
     GregorianM {gmYear = y', gmMonth = m'} = compare y y' <> compare m m'
 
+deriving instance Eq Interval
+
+deriving instance Ord Interval
+
+deriving instance Hashable Interval
+
 deriving instance Eq ModPat
 
 deriving instance Ord ModPat
@@ -170,26 +174,55 @@ deriving instance Show DatePat
 
 deriving instance Hashable DatePat
 
+data Budget = Budget
+  { budgetLabel :: Text
+  , incomes :: [Income]
+  , pretax :: [IntervalAllocation]
+  , tax :: [IntervalAllocation]
+  , posttax :: [IntervalAllocation]
+  , transfers :: [Transfer]
+  , shadowTransfers :: [ShadowTransfer]
+  }
+
 deriving instance Eq Budget
 
+deriving instance Generic Budget
+
 deriving instance Hashable Budget
 
+deriving instance FromDhall Budget
+
 deriving instance Eq TaggedAcnt
 
 deriving instance Hashable TaggedAcnt
 
 deriving instance Ord TaggedAcnt
 
+type CurID = T.Text
+
+data Income = Income
+  { incGross :: Decimal
+  , incCurrency :: CurID
+  , incWhen :: DatePat
+  , incPretax :: [Allocation]
+  , incTaxes :: [Allocation]
+  , incPosttax :: [Allocation]
+  , incFrom :: TaggedAcnt
+  , incToBal :: TaggedAcnt
+  }
+
 deriving instance Eq Income
 
+deriving instance Generic Income
+
 deriving instance Hashable Income
 
-deriving instance Eq Tax
+deriving instance FromDhall Income
-
-deriving instance Hashable Tax
 
 deriving instance Eq Amount
 
+deriving instance Ord Amount
+
 deriving instance Hashable Amount
 
 deriving instance Eq Exchange
@@ -200,10 +233,32 @@ deriving instance Eq BudgetCurrency
 
 deriving instance Hashable BudgetCurrency
 
+data Allocation_ a = Allocation_
+  { alloTo :: TaggedAcnt
+  , alloAmts :: [a]
+  , alloCur :: BudgetCurrency
+  }
+
+type Allocation = Allocation_ Amount
+
 deriving instance Eq Allocation
 
+deriving instance Generic Allocation
+
 deriving instance Hashable Allocation
 
+deriving instance FromDhall Allocation
+
+type IntervalAllocation = Allocation_ IntervalAmount
+
+deriving instance Eq IntervalAllocation
+
+deriving instance Generic IntervalAllocation
+
+deriving instance Hashable IntervalAllocation
+
+deriving instance FromDhall IntervalAllocation
+
 toPersistText :: Show a => a -> PersistValue
 toPersistText = PersistText . T.pack . show
 
@@ -216,16 +271,54 @@ fromPersistText what x =
 
 deriving instance Eq AmountType
 
+deriving instance Ord AmountType
+
 deriving instance Hashable AmountType
 
-deriving instance Eq TimeAmount
+data TimeAmount a = TimeAmount
+  { taWhen :: a
+  , taAmt :: Amount
+  , taAmtType :: AmountType
+  }
+  deriving (Eq, Ord, Functor, Generic, FromDhall, Hashable, Foldable, Traversable)
 
-deriving instance Hashable TimeAmount
+type DateAmount = TimeAmount DatePat
+
+-- deriving instance Eq DateAmount
+
+-- deriving instance Generic DateAmount
+
+-- deriving instance Hashable DateAmount
+
+-- deriving instance FromDhall DateAmount
+
+type IntervalAmount = TimeAmount Interval
+
+-- deriving instance Eq IntervalAmount
+
+-- deriving instance Ord IntervalAmount
+
+-- deriving instance Generic IntervalAmount
+
+-- deriving instance Hashable IntervalAmount
+
+-- deriving instance FromDhall IntervalAmount
+
+data Transfer = Transfer
+  { transFrom :: TaggedAcnt
+  , transTo :: TaggedAcnt
+  , transAmounts :: [DateAmount]
+  , transCurrency :: BudgetCurrency
+  }
 
 deriving instance Eq Transfer
 
+deriving instance Generic Transfer
+
 deriving instance Hashable Transfer
 
+deriving instance FromDhall Transfer
+
 deriving instance Eq ShadowTransfer
 
 deriving instance Hashable ShadowTransfer
@@ -258,6 +351,8 @@ deriving instance Show MatchDate
 
 deriving instance Eq Decimal
 
+deriving instance Ord Decimal
+
 deriving instance Hashable Decimal
 
 deriving instance Show Decimal
@@ -360,8 +455,6 @@ instance FromDhall a => FromDhall (Config_ a)
 -- TODO newtypes for these?
 type AcntID = T.Text
 
-type CurID = T.Text
-
 type TagID = T.Text
 
 data Statement

lib/Internal/Utils.hs

@@ -6,6 +6,7 @@ module Internal.Utils
   , matches
   , fromGregorian'
   , resolveBounds
+  , resolveBounds_
   , leftToMaybe
   , dec2Rat
   , concatEithers2
@@ -130,9 +131,13 @@ inBounds :: (Day, Day) -> Day -> Bool
 inBounds (d0, d1) x = d0 <= x && x < d1
 
 resolveBounds :: Interval -> EitherErr Bounds
-resolveBounds Interval {intStart = s, intEnd = e} =
+resolveBounds i@Interval {intStart = s} =
+  resolveBounds_ (s {gYear = gYear s + 50}) i
+
+resolveBounds_ :: Gregorian -> Interval -> EitherErr Bounds
+resolveBounds_ def Interval {intStart = s, intEnd = e} =
   case fromGregorian' <$> e of
-    Nothing -> Right $ toBounds $ fromGregorian' $ s {gYear = gYear s + 50}
+    Nothing -> Right $ toBounds $ fromGregorian' def
     Just e_
       | s_ < e_ -> Right $ toBounds e_
       | otherwise -> Left $ BoundsError s e