From ad4cb6a70277eb321a735b4616442ae506168033 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Thu, 16 Mar 2023 23:53:57 -0400 Subject: [PATCH] ENH use intervals to define allocations --- dhall/Types.dhall | 29 +++++--- lib/Internal/Insert.hs | 151 ++++++++++++++++++++++++++++------------- lib/Internal/Types.hs | 121 +++++++++++++++++++++++++++++---- lib/Internal/Utils.hs | 9 ++- 4 files changed, 237 insertions(+), 73 deletions(-) diff --git a/dhall/Types.dhall b/dhall/Types.dhall index 5447801..423eb20 100644 --- a/dhall/Types.dhall +++ b/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 = - { alloTo : TaggedAcnt, alloAmts : List Amount, alloCur : BudgetCurrency } +let Allocation_ = + \(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 diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs index b744088..5c9e2fe 100644 --- a/lib/Internal/Insert.hs +++ b/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}) = - whenHash CTBudget b [] $ \key -> do - res1 <- mapM (insertIncome key name) is - res2 <- expandTransfers key name es - unlessLefts (concatEithers2 (fmap concat $ concatEithersL res1) res2 (++)) $ - \txs -> do - unlessLefts (addShadowTransfers ss txs) $ \shadow -> do - let bals = balanceTransfers $ txs ++ shadow - concat <$> mapM insertBudgetTx bals +insertBudget + b@( Budget + { budgetLabel + , incomes + , transfers + , shadowTransfers + , pretax + , tax + , posttax + } + ) = + whenHash CTBudget b [] $ \key -> do + unlessLefts intAllos $ \intAllos_ -> do + res1 <- mapM (insertIncome key budgetLabel intAllos_) incomes + res2 <- expandTransfers key budgetLabel transfers + unlessLefts (concatEithers2 (fmap concat $ concatEithersL res1) res2 (++)) $ + \txs -> 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 - tax <- - concatEitherL - <$> mapM (lift . fromTax day meta (taAcnt incFrom)) incTaxes - post <- fromAllos incPosttax + pre <- fromAllos $ incPretax ++ mapMaybe (selectAllos day) intPre + -- TODO ensure these are all expense accounts + tax <- fromAllos $ incTaxes ++ mapMaybe (selectAllos day) intTax + post <- fromAllos $ incPosttax ++ mapMaybe (selectAllos day) intPost 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? -fromTax - :: MonadFinance m - => Day - -> BudgetMeta - -> AcntID - -> Tax - -> m (EitherErr BudgetTxType) -fromTax day meta from Tax {taxAcnt = to, taxValue = v} = do - res <- checkAcntType ExpenseT to - return $ fmap go res - where - go to_ = - BudgetTxType - { bttTx = - BudgetTx - { btFrom = TaggedAcnt from [] - , btWhen = day - , btTo = TaggedAcnt to_ [] - , btValue = dec2Rat v - , btDesc = "" - , btMeta = meta - } - , bttType = FixedAmt - } +-- -- TODO maybe allow tags here? +-- fromTax +-- :: MonadFinance m +-- => Day +-- -> BudgetMeta +-- -> AcntID +-- -> Tax +-- -> m (EitherErr BudgetTxType) +-- fromTax day meta from Tax {taxAcnt = to, taxValue = v} = do +-- res <- checkAcntType ExpenseT to +-- return $ fmap go res +-- where +-- go to_ = +-- BudgetTxType +-- { bttTx = +-- BudgetTx +-- { btFrom = TaggedAcnt from [] +-- , btWhen = day +-- , btTo = TaggedAcnt to_ [] +-- , btValue = dec2Rat v +-- , btDesc = "" +-- , btMeta = meta +-- } +-- , 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 = sum . fmap (dec2Rat . taxValue) +-- sumTaxes :: [Tax] -> Rational +-- 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 diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs index 99b7393..fc6a446 100644 --- a/lib/Internal/Types.hs +++ b/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 "Allocation" "Allocation" "(./dhall/Types.dhall).Allocation" - , SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income" - , SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget" - , SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer" - , SingleConstructor "Exchange" "Exchange" "(./dhall/Types.dhall).Exchange" + , -- , SingleConstructor "TimeAmount" "TimeAmount" "(./dhall/Types.dhall).TimeAmount" + -- , SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income" + -- , SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget" + -- , SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer" + 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 Hashable Tax +deriving instance FromDhall Income 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 diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index d259cae..c8c5581 100644 --- a/lib/Internal/Utils.hs +++ b/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