From 5dfbc3ef419e1c9e9800f79b2cb635dcb3cb7705 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Mon, 29 May 2023 13:09:17 -0400 Subject: [PATCH] ADD local budget interval --- lib/Internal/Database/Ops.hs | 11 ++- lib/Internal/Insert.hs | 157 ++++++++++++++++++++--------------- lib/Internal/Types.hs | 1 + lib/Internal/Utils.hs | 19 ++++- 4 files changed, 117 insertions(+), 71 deletions(-) diff --git a/lib/Internal/Database/Ops.hs b/lib/Internal/Database/Ops.hs index f7c95a3..182f6f0 100644 --- a/lib/Internal/Database/Ops.hs +++ b/lib/Internal/Database/Ops.hs @@ -19,8 +19,15 @@ import Database.Esqueleto.Experimental ((==.), (^.)) import qualified Database.Esqueleto.Experimental as E import Database.Esqueleto.Internal.Internal (SqlSelect) import Database.Persist.Monad --- import Database.Persist.Sql hiding (delete, runMigration, (==.), (||.)) -import Database.Persist.Sqlite hiding (delete, deleteWhere, insert, insertKey, runMigration, (==.), (||.)) +import Database.Persist.Sqlite hiding + ( delete + , deleteWhere + , insert + , insertKey + , runMigration + , (==.) + , (||.) + ) import GHC.Err import Internal.Types import Internal.Utils diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs index be2838c..6f06a70 100644 --- a/lib/Internal/Insert.hs +++ b/lib/Internal/Insert.hs @@ -95,6 +95,22 @@ expandMDYPat lower upper (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = r dayToWeekday :: Day -> Int dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7 +askDays + :: (MonadFinance m, MonadInsertError m) + => DatePat + -> Maybe Interval + -> m [Day] +askDays dp i = do + globalBounds <- askDBState kmBudgetInterval + case i of + Just i' -> do + localBounds <- liftExcept $ resolveBounds i' + let bounds = intersectBounds globalBounds localBounds + maybe (return []) expand bounds + Nothing -> expand globalBounds + where + expand bs = liftExcept $ expandDatePat bs dp + withDates :: (MonadSqlQuery m, MonadFinance m, MonadInsertError m) => DatePat @@ -105,15 +121,13 @@ withDates dp f = do days <- liftExcept $ expandDatePat bounds dp combineErrors $ fmap f days -foldDates - :: (MonadSqlQuery m, MonadFinance m, MonadInsertError m) - => DatePat +foldDays + :: MonadInsertError m + => (Day -> Day -> m a) -> Day - -> (Day -> Day -> m a) + -> [Day] -> m [a] -foldDates dp start f = do - bounds <- askDBState kmBudgetInterval - days <- liftExcept $ expandDatePat bounds dp +foldDays f start days = combineErrors $ snd $ L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days @@ -145,11 +159,12 @@ insertBudget , bgtPretax , bgtTax , bgtPosttax + , bgtInterval } = whenHash CTBudget b () $ \key -> do intAllos <- combineError3 pre_ tax_ post_ (,,) - let res1 = mapErrors (insertIncome key bgtLabel intAllos) bgtIncomes - let res2 = expandTransfers key bgtLabel bgtTransfers + let res1 = mapErrors (insertIncome key bgtLabel intAllos bgtInterval) bgtIncomes + let res2 = expandTransfers key bgtLabel bgtInterval bgtTransfers txs <- combineError (concat <$> res1) res2 (++) m <- askDBState kmCurrency shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs @@ -160,7 +175,7 @@ insertBudget post_ = sortAllos bgtPosttax sortAllos = liftExcept . combineErrors . fmap sortAllo -type BoundAllocation = Allocation (Day, Day) +type BoundAllocation = Allocation Bounds type IntAllocations = ( [BoundAllocation PretaxValue] @@ -180,7 +195,7 @@ sortAllo a@Allocation {alloAmts = as} = do res <- case xs of [] -> resolveBounds start (y : _) -> resolveBounds_ (intStart $ amtWhen y) start - foldBounds (x {amtWhen = expandBounds res} : acc) xs + foldBounds (x {amtWhen = res} : acc) xs -- TODO this is going to be O(n*m), which might be a problem? addShadowTransfers @@ -209,35 +224,35 @@ fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, st Just $ -- TODO does this actually share the same metadata as the "parent" tx? FlatTransfer - { cbtMeta = cbtMeta tx - , cbtWhen = cbtWhen tx - , cbtCur = stCurrency - , cbtFrom = stFrom - , cbtTo = stTo - , cbtValue = UnbalancedValue stType $ v * cvValue (cbtValue tx) - , cbtDesc = stDesc + { ftMeta = ftMeta tx + , ftWhen = ftWhen tx + , ftCur = stCurrency + , ftFrom = stFrom + , ftTo = stTo + , ftValue = UnbalancedValue stType $ v * cvValue (ftValue tx) + , ftDesc = stDesc } shadowMatches :: TransferMatcher -> UnbalancedTransfer -> InsertExcept Bool shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do - valRes <- valMatches tmVal $ cvValue $ cbtValue tx + valRes <- valMatches tmVal $ cvValue $ ftValue tx return $ - memberMaybe (taAcnt $ cbtFrom tx) tmFrom - && memberMaybe (taAcnt $ cbtTo tx) tmTo - && maybe True (`dateMatches` cbtWhen tx) tmDate + memberMaybe (taAcnt $ ftFrom tx) tmFrom + && memberMaybe (taAcnt $ ftTo tx) tmTo + && maybe True (`dateMatches` ftWhen tx) tmDate && valRes where memberMaybe x AcntSet {asList, asInclude} = (if asInclude then id else not) $ x `elem` asList balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer] -balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn cbtWhen +balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen where - go bals f@FlatTransfer {cbtFrom, cbtTo, cbtValue = UnbalancedValue {cvValue, cvType}} = - let balTo = M.findWithDefault 0 cbtTo bals + go bals f@FlatTransfer {ftFrom, ftTo, ftValue = UnbalancedValue {cvValue, cvType}} = + let balTo = M.findWithDefault 0 ftTo bals x = amtToMove balTo cvType cvValue - bals' = mapAdd_ cbtTo x $ mapAdd_ cbtFrom (-x) bals - in (bals', f {cbtValue = x}) + bals' = mapAdd_ ftTo x $ mapAdd_ ftFrom (-x) bals + in (bals', f {ftValue = 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 -- target value @@ -255,13 +270,13 @@ data BudgetMeta = BudgetMeta deriving (Show) data FlatTransfer v = FlatTransfer - { cbtFrom :: !TaggedAcnt - , cbtTo :: !TaggedAcnt - , cbtValue :: !v - , cbtWhen :: !Day - , cbtDesc :: !T.Text - , cbtMeta :: !BudgetMeta - , cbtCur :: !BudgetCurrency + { ftFrom :: !TaggedAcnt + , ftTo :: !TaggedAcnt + , ftValue :: !v + , ftWhen :: !Day + , ftDesc :: !T.Text + , ftMeta :: !BudgetMeta + , ftCur :: !BudgetCurrency } deriving (Show) @@ -276,16 +291,18 @@ type UnbalancedTransfer = FlatTransfer UnbalancedValue type BalancedTransfer = FlatTransfer Rational insertIncome - :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) + :: (MonadInsertError m, MonadFinance m) => CommitRId -> T.Text -> IntAllocations + -> Maybe Interval -> Income -> m [UnbalancedTransfer] insertIncome key name (intPre, intTax, intPost) + localInterval Income { incWhen , incCurrency @@ -304,7 +321,8 @@ insertIncome -- 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 :( - res <- foldDates incWhen start (allocate precision gross) + days <- askDays incWhen localInterval + res <- foldDays (allocate precision gross) start days return $ concat res where start = fromGregorian' $ pStart incPayPeriod @@ -330,13 +348,13 @@ insertIncome balance = aftertaxGross - sumAllos post bal = FlatTransfer - { cbtMeta = meta - , cbtWhen = day - , cbtFrom = incFrom - , cbtCur = NoX incCurrency - , cbtTo = incToBal - , cbtValue = UnbalancedValue BTFixed balance - , cbtDesc = "balance after deductions" + { ftMeta = meta + , ftWhen = day + , ftFrom = incFrom + , ftCur = NoX incCurrency + , ftTo = incToBal + , ftValue = UnbalancedValue BTFixed balance + , ftDesc = "balance after deductions" } in if balance < 0 then throwError $ InsertException [IncomeError day name balance] @@ -404,13 +422,13 @@ allo2Trans -> UnbalancedTransfer allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} = FlatTransfer - { cbtMeta = meta - , cbtWhen = day - , cbtFrom = from - , cbtCur = faCur - , cbtTo = faTo - , cbtValue = UnbalancedValue BTFixed faValue - , cbtDesc = faDesc + { ftMeta = meta + , ftWhen = day + , ftFrom = from + , ftCur = faCur + , ftTo = faTo + , ftValue = UnbalancedValue BTFixed faValue + , ftDesc = faDesc } allocateTax @@ -501,12 +519,19 @@ expandTransfers :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) => CommitRId -> T.Text + -> Maybe Interval -> [BudgetTransfer] -> m [UnbalancedTransfer] -expandTransfers key name ts = - fmap (L.sortOn cbtWhen . concat) $ - combineErrors $ - fmap (expandTransfer key name) ts +expandTransfers key name localInterval ts = do + txs <- + fmap (L.sortOn ftWhen . concat) $ + combineErrors $ + fmap (expandTransfer key name) ts + case localInterval of + Nothing -> return txs + Just i -> do + bounds <- liftExcept $ resolveBounds i + return $ filter (inBounds bounds . ftWhen) txs initialCurrency :: BudgetCurrency -> CurID initialCurrency (NoX c) = c @@ -533,28 +558,28 @@ expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFro let meta = BudgetMeta {bmCommit = key, bmName = name} return FlatTransfer - { cbtMeta = meta - , cbtWhen = day - , cbtCur = transCurrency - , cbtFrom = transFrom - , cbtTo = transTo - , cbtValue = UnbalancedValue y $ roundPrecision precision v - , cbtDesc = desc + { ftMeta = meta + , ftWhen = day + , ftCur = transCurrency + , ftFrom = transFrom + , ftTo = transTo + , ftValue = UnbalancedValue y $ roundPrecision precision v + , ftDesc = desc } insertBudgetTx :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) => BalancedTransfer -> m () -insertBudgetTx FlatTransfer {cbtFrom, cbtTo, cbtMeta, cbtCur, cbtValue, cbtDesc, cbtWhen} = do - ((sFrom, sTo), exchange) <- splitPair cbtFrom cbtTo cbtCur cbtValue +insertBudgetTx FlatTransfer {ftFrom, ftTo, ftMeta, ftCur, ftValue, ftDesc, ftWhen} = do + ((sFrom, sTo), exchange) <- splitPair ftFrom ftTo ftCur ftValue insertPair sFrom sTo forM_ exchange $ uncurry insertPair where insertPair from to = do - k <- insert $ TransactionR (bmCommit cbtMeta) cbtWhen cbtDesc + k <- insert $ TransactionR (bmCommit ftMeta) ftWhen ftDesc insertBudgetLabel k from insertBudgetLabel k to insertBudgetLabel k split = do sk <- insertSplit k split - insert_ $ BudgetLabelR sk $ bmName cbtMeta + insert_ $ BudgetLabelR sk $ bmName ftMeta type SplitPair = (KeySplit, KeySplit) @@ -646,7 +671,7 @@ insertHistTransfer readHistStmt :: (MonadUnliftIO m, MonadFinance m) => Statement -> m (Maybe (CommitR, [KeyTx])) readHistStmt i = whenHash_ CTImport i $ do bs <- readImport i - bounds <- expandBounds <$> askDBState kmStatementInterval + bounds <- askDBState kmStatementInterval liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs insertHistStmt :: (MonadSqlQuery m) => CommitR -> [KeyTx] -> m () diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs index 6b7fc77..ab12036 100644 --- a/lib/Internal/Types.hs +++ b/lib/Internal/Types.hs @@ -200,6 +200,7 @@ data Budget = Budget , bgtPosttax :: [MultiAllocation PosttaxValue] , bgtTransfers :: [BudgetTransfer] , bgtShadowTransfers :: [ShadowTransfer] + , bgtInterval :: !(Maybe Interval) } deriving instance Hashable PretaxValue diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index 729fe65..e5723f9 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -8,6 +8,7 @@ module Internal.Utils , fromGregorian' , resolveBounds , resolveBounds_ + , intersectBounds , liftInner , liftExceptT , liftExcept @@ -161,14 +162,26 @@ compareDate (In md offset) x = do fromGregorian' :: Gregorian -> Day fromGregorian' = uncurry3 fromGregorian . gregTup --- TODO misleading name -inBounds :: (Day, Day) -> Day -> Bool -inBounds (d0, d1) x = d0 <= x && x < d1 +inBounds :: Bounds -> Day -> Bool +inBounds bs = withinDays (expandBounds bs) + +withinDays :: (Day, Day) -> Day -> Bool +withinDays (d0, d1) x = d0 <= x && x < d1 resolveBounds :: Interval -> InsertExcept Bounds resolveBounds i@Interval {intStart = s} = resolveBounds_ (s {gYear = gYear s + 50}) i +-- TODO not DRY +intersectBounds :: Bounds -> Bounds -> Maybe Bounds +intersectBounds a b = + if b' > a' then Nothing else Just (a', fromIntegral $ diffDays b' a' - 1) + where + (a0, a1) = expandBounds a + (b0, b1) = expandBounds b + a' = max a0 a1 + b' = min b0 b1 + resolveBounds_ :: Gregorian -> Interval -> InsertExcept Bounds resolveBounds_ def Interval {intStart = s, intEnd = e} = case fromGregorian' <$> e of