From 2946a8f9e2bbfc42382248aadd1b2de4b66bceb7 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Fri, 7 Jul 2023 00:20:18 -0400 Subject: [PATCH] ADD priority flag to keep tx's sorted always --- dhall/Types.dhall | 4 +- lib/Internal/Budget.hs | 115 ++++++++++++++++----------------- lib/Internal/Database.hs | 14 ++-- lib/Internal/History.hs | 10 +-- lib/Internal/Types/Database.hs | 1 + lib/Internal/Types/Dhall.hs | 1 + lib/Internal/Types/Main.hs | 4 ++ lib/Internal/Utils.hs | 16 +++-- 8 files changed, 89 insertions(+), 76 deletions(-) diff --git a/dhall/Types.dhall b/dhall/Types.dhall index a48121e..fd6a45a 100644 --- a/dhall/Types.dhall +++ b/dhall/Types.dhall @@ -679,7 +679,7 @@ let Amount = -} \(w : Type) -> \(v : Type) -> - { amtWhen : w, amtValue : v, amtDesc : Text } + { amtWhen : w, amtValue : v, amtDesc : Text, amtPriority : Integer } let TransferType = {- @@ -967,11 +967,13 @@ let Income = (if any) after all allocations have been applied. -} TaggedAcnt.Type + , incPriority : Integer } , default = { incPretax = [] : List (SingleAllocation PretaxValue) , incTaxes = [] : List (SingleAllocation TaxValue) , incPosttaxx = [] : List (SingleAllocation PosttaxValue) + , incPriority = +0 } } diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs index eeb7215..035a49e 100644 --- a/lib/Internal/Budget.hs +++ b/lib/Internal/Budget.hs @@ -92,29 +92,30 @@ readIncome Income { incWhen , incCurrency - , incFrom + , incFrom = TaggedAcnt {taAcnt = srcAcnt, taTags = srcTags} , incPretax , incPosttax , incTaxes - , incToBal + , incToBal = TaggedAcnt {taAcnt = destAcnt, taTags = destTags} , incGross , incPayPeriod + , incPriority } = combineErrorM (combineError incRes nonIncRes (,)) - (combineError precRes dayRes (,)) - $ \_ (precision, days) -> do - let gross = roundPrecision precision incGross - concat <$> foldDays (allocate precision gross) start days + (combineError cpRes dayRes (,)) + $ \_ (cp, days) -> do + let gross = roundPrecisionCur cp incGross + foldDays (allocate cp gross) start days where - incRes = isIncomeAcnt $ taAcnt incFrom + incRes = isIncomeAcnt srcAcnt nonIncRes = mapErrors isNotIncomeAcnt $ - taAcnt incToBal + destAcnt : (alloAcnt <$> incPretax) ++ (alloAcnt <$> incTaxes) ++ (alloAcnt <$> incPosttax) - precRes = lookupCurrencyPrec incCurrency + cpRes = lookupCurrency incCurrency dayRes = liftExcept $ expandDatePat ds incWhen start = fromGregorian' $ pStart incPayPeriod pType' = pType incPayPeriod @@ -123,8 +124,9 @@ readIncome flatPost = concatMap flattenAllo incPosttax sumAllos = sum . fmap faValue -- TODO ensure these are all the "correct" accounts - allocate precision gross prevDay day = do + allocate cp gross prevDay day = do scaler <- liftExcept $ periodScaler pType' prevDay day + let precision = cpPrec cp let (preDeductions, pre) = allocatePre precision gross $ flatPre ++ concatMap (selectAllos day) intPre @@ -135,31 +137,39 @@ readIncome let post = allocatePost precision aftertaxGross $ flatPost ++ concatMap (selectAllos day) intPost - let balance = aftertaxGross - sumAllos post -- TODO double or rational here? - primary <- - entryPair - incFrom - incToBal - incCurrency - "balance after deductions" - (fromRational balance) - () - -- TODO make this into one large tx? - allos <- mapErrors (allo2Trans key name day incFrom) (pre ++ tax ++ post) - let bal = - Tx - { txCommit = key - , txDate = day - , txPrimary = Left primary - , txOther = [] - , txDescr = "balance after deductions" - , txBudget = name + let src = + Entry + { eAcnt = srcAcnt + , eValue = () + , eComment = "" + , eTags = srcTags } - -- TODO use real name here - if balance < 0 - then throwError $ InsertException [IncomeError day name balance] - else return (bal : allos) + let dest = + Entry + { eAcnt = destAcnt + , eValue = () + , eComment = "balance after deductions" + , eTags = destTags + } + let allos = allo2Trans <$> (pre ++ tax ++ post) + let primary = + EntrySet + { esTotalValue = gross + , esCurrency = cp + , esFrom = HalfEntrySet {hesPrimary = src, hesOther = []} + , esTo = HalfEntrySet {hesPrimary = dest, hesOther = allos} + } + return $ + Tx + { txCommit = key + , txDate = day + , txPrimary = Left primary + , txOther = [] + , txDescr = "" + , txBudget = name + , txPriority = incPriority + } periodScaler :: PeriodType @@ -236,49 +246,35 @@ checkAcntTypes ts i = void $ go =<< lookupAccountType i | otherwise = throwError $ InsertException [AccountError i ts] flattenAllo :: SingleAllocation v -> [FlatAllocation v] -flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts +flattenAllo Allocation {alloAmts, alloTo} = fmap go alloAmts where go Amount {amtValue, amtDesc} = FlatAllocation - { faCur = alloCur - , faTo = alloTo + { faTo = alloTo , faValue = amtValue , faDesc = amtDesc } -- ASSUME allocations are sorted selectAllos :: Day -> DaySpanAllocation v -> [FlatAllocation v] -selectAllos day Allocation {alloAmts, alloCur, alloTo} = +selectAllos day Allocation {alloAmts, alloTo} = go <$> filter ((`inDaySpan` day) . amtWhen) alloAmts where go Amount {amtValue, amtDesc} = FlatAllocation - { faCur = alloCur - , faTo = alloTo + { faTo = alloTo , faValue = amtValue , faDesc = amtDesc } -allo2Trans - :: (MonadInsertError m, MonadFinance m) - => CommitR - -> T.Text - -> Day - -> TaggedAcnt - -> FlatAllocation Rational - -> m (Tx CommitR) -allo2Trans meta name day from FlatAllocation {faValue, faTo, faDesc, faCur} = do - -- TODO double here? - p <- entryPair from faTo faCur faDesc (fromRational faValue) () - return - Tx - { txCommit = meta - , txDate = day - , txPrimary = Left p - , txOther = [] - , txDescr = faDesc - , txBudget = name - } +allo2Trans :: FlatAllocation Rational -> Entry AcntID (LinkDeferred Rational) TagID +allo2Trans FlatAllocation {faValue, faTo = TaggedAcnt {taAcnt, taTags}, faDesc} = + Entry + { eValue = LinkDeferred (EntryValue TFixed faValue) + , eComment = faDesc + , eAcnt = taAcnt + , eTags = taTags + } allocatePre :: Natural @@ -414,6 +410,5 @@ data FlatAllocation v = FlatAllocation { faValue :: !v , faDesc :: !T.Text , faTo :: !TaggedAcnt - , faCur :: !CurID } deriving (Functor, Show) diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs index d680f0f..c050ba5 100644 --- a/lib/Internal/Database.hs +++ b/lib/Internal/Database.hs @@ -447,6 +447,7 @@ readUpdates hashes = do ( entrysets ^. EntrySetRId , txs ^. TransactionRDate , txs ^. TransactionRBudgetName + , txs ^. TransactionRPriority , ( entrysets ^. EntrySetRCurrency , currencies ^. CurrencyRPrecision @@ -456,10 +457,10 @@ readUpdates hashes = do ) ) let (toUpdate, toRead) = L.partition (E.unValue . fst) xs - toUpdate' <- liftExcept $ mapErrors makeUES $ groupKey (\(i, _, _, _) -> i) (snd <$> toUpdate) + toUpdate' <- liftExcept $ mapErrors makeUES $ groupKey (\(i, _, _, _, _) -> i) (snd <$> toUpdate) return (makeRE . snd <$> toRead, toUpdate') where - makeUES ((_, day, name, (curID, prec)), es) = do + makeUES ((_, day, name, pri, (curID, prec)), es) = do let res = bimap NE.nonEmpty NE.nonEmpty $ NE.partition ((< 0) . entryRIndex . snd) $ @@ -485,6 +486,7 @@ readUpdates hashes = do , utToUnk = toUnk , utTotalValue = tot , utBudget = E.unValue name + , utPriority = E.unValue pri } Right x -> Right $ @@ -499,9 +501,10 @@ readUpdates hashes = do , utToUnk = toUnk , utTotalValue = () , utBudget = E.unValue name + , utPriority = E.unValue pri } _ -> throwError undefined - makeRE ((_, day, name, (curID, _)), entry) = + makeRE ((_, day, name, pri, (curID, _)), entry) = let e = entityVal entry in ReadEntry { reDate = E.unValue day @@ -509,6 +512,7 @@ readUpdates hashes = do , reAcnt = entryRAccount e , reValue = entryRValue e , reBudget = E.unValue name + , rePriority = E.unValue pri } splitFrom @@ -660,8 +664,8 @@ insertAll ebs = do -- getCommit (BudgetCommit c _) = c insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m () -insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxBudget} = do - k <- insert $ TransactionR c itxDate itxDescr itxBudget +insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxBudget, itxPriority} = do + k <- insert $ TransactionR c itxDate itxDescr itxBudget itxPriority mapM_ (uncurry (insertEntrySet k)) $ zip [0 ..] (NE.toList itxEntrySets) where insertEntrySet tk i InsertEntrySet {iesCurrency, iesFromEntries, iesToEntries} = do diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs index 806d716..8727424 100644 --- a/lib/Internal/History.hs +++ b/lib/Internal/History.hs @@ -267,7 +267,7 @@ matchNonDates ms = go ([], [], initZipper ms) matches :: MonadFinance m => MatchRe -> TxRecord -> InsertExceptT m (MatchRes (Tx ())) matches - StatementParser {spTx, spOther, spVal, spDate, spDesc} + StatementParser {spTx, spOther, spVal, spDate, spDesc, spPriority} r@TxRecord {trDate, trAmount, trDesc, trOther} = do res <- liftInner $ combineError3 val other desc $ @@ -280,10 +280,11 @@ matches date = maybe True (`dateMatches` trDate) spDate other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True spOther desc = maybe (return True) (matchMaybe trDesc . snd) spDesc - convert tg = MatchPass <$> toTx tg r + convert tg = MatchPass <$> toTx (fromIntegral spPriority) tg r -toTx :: MonadFinance m => TxGetter -> TxRecord -> InsertExceptT m (Tx ()) +toTx :: MonadFinance m => Int -> TxGetter -> TxRecord -> InsertExceptT m (Tx ()) toTx + priority TxGetter { tgFrom , tgTo @@ -305,8 +306,9 @@ toTx , esFrom = f , esTo = t } - , txOther = fmap Left ss + , txOther = Left <$> ss , txBudget = historyName + , txPriority = priority } where curRes = do diff --git a/lib/Internal/Types/Database.hs b/lib/Internal/Types/Database.hs index f83fc34..b3f4564 100644 --- a/lib/Internal/Types/Database.hs +++ b/lib/Internal/Types/Database.hs @@ -45,6 +45,7 @@ TransactionR sql=transactions date Day description T.Text budgetName T.Text + priority Int deriving Show Eq EntrySetR sql=entry_sets transaction TransactionRId OnDeleteCascade diff --git a/lib/Internal/Types/Dhall.hs b/lib/Internal/Types/Dhall.hs index 474f448..08d63a1 100644 --- a/lib/Internal/Types/Dhall.hs +++ b/lib/Internal/Types/Dhall.hs @@ -243,6 +243,7 @@ data Income = Income , incFrom :: TaggedAcnt , incToBal :: TaggedAcnt , incPayPeriod :: !Period + , incPriority :: !Int } deriving instance Hashable HourlyPeriod diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs index fb01374..bc8b4e9 100644 --- a/lib/Internal/Types/Main.hs +++ b/lib/Internal/Types/Main.hs @@ -76,6 +76,7 @@ data ReadEntry = ReadEntry , reAcnt :: !AccountRId , reValue :: !Rational , reDate :: !Day + , rePriority :: !Int , reBudget :: !T.Text } deriving (Show) @@ -124,6 +125,7 @@ data UpdateEntrySet f t = UpdateEntrySet , utDate :: !Day , utTotalValue :: !t , utBudget :: !T.Text + , utPriority :: !Int } deriving (Show) @@ -245,6 +247,7 @@ data TxCommit = HistoryCommit CommitR | BudgetCommit CommitR T.Text data Tx k = Tx { txDescr :: !T.Text , txDate :: !Day + , txPriority :: !Int , txPrimary :: !(Either PrimaryEntrySet TransferEntrySet) , txOther :: ![Either SecondayEntrySet ShadowEntrySet] , txCommit :: !k @@ -266,6 +269,7 @@ data InsertEntrySet = InsertEntrySet data InsertTx = InsertTx { itxDescr :: !T.Text , itxDate :: !Day + , itxPriority :: !Int , itxEntrySets :: !(NonEmpty InsertEntrySet) , itxCommit :: !CommitR , itxBudget :: !T.Text diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index fea403b..e7e4b69 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -692,7 +692,7 @@ balanceTxs ebs = go (ToRead ReadEntry {reCurrency, reAcnt, reValue, reBudget}) = do modify $ mapAdd_ (reAcnt, (reCurrency, reBudget)) reValue return Nothing - go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate, txBudget}) = do + go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate, txBudget, txPriority}) = do e <- either (balancePrimaryEntrySet txBudget) (balanceSecondaryEntrySet txBudget) txPrimary let tot = sum $ fmap (eValue . ieEntry) $ NE.toList $ iesFromEntries e es <- mapErrors (either (balanceSecondaryEntrySet txBudget) (balancePrimaryEntrySet txBudget . fromShadow tot)) txOther @@ -704,15 +704,17 @@ balanceTxs ebs = , itxEntrySets = e :| es , itxCommit = txCommit , itxBudget = txBudget + , itxPriority = txPriority } return $ Just $ Right tx fromShadow tot e@EntrySet {esTotalValue} = e {esTotalValue = tot * toRational esTotalValue} -binDate :: EntryBin -> Day -binDate (ToUpdate (Right UpdateEntrySet {utDate})) = utDate -binDate (ToUpdate (Left UpdateEntrySet {utDate})) = utDate -binDate (ToRead ReadEntry {reDate}) = reDate -binDate (ToInsert Tx {txDate}) = txDate +binDate :: EntryBin -> (Day, Int) +binDate (ToRead ReadEntry {reDate, rePriority}) = (reDate, rePriority) +binDate (ToInsert Tx {txDate, txPriority}) = (txDate, txPriority) +binDate (ToUpdate u) = either go go u + where + go UpdateEntrySet {utDate, utPriority} = (utDate, utPriority) type BCKey = (CurrencyRId, Text) @@ -1044,6 +1046,7 @@ expandTransfer tc name bounds Transfer {transAmounts, transTo, transCurrency, tr { amtWhen = pat , amtValue = TransferValue {tvVal = v, tvType = t} , amtDesc = desc + , amtPriority = pri } = withDates bounds pat $ \day -> do p <- entryPair transFrom transTo transCurrency desc () (EntryValue t (toRational (-v))) @@ -1055,6 +1058,7 @@ expandTransfer tc name bounds Transfer {transAmounts, transTo, transCurrency, tr , txOther = [] , txDescr = desc , txBudget = name + , txPriority = fromIntegral pri } entryPair