ndwarshuis
/
pwncash
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

ADD priority flag to keep tx's sorted always

This commit is contained in:
Nathan Dwarshuis 2023-07-07 00:20:18 -04:00
parent 24bc9a239b
commit 2946a8f9e2
8 changed files with 89 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
dhall/Types.dhall
View File

@ -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
}
}

115
lib/Internal/Budget.hs
View File

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

14
lib/Internal/Database.hs
View File

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

10
lib/Internal/History.hs
View File

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

1
lib/Internal/Types/Database.hs
View File

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

1
lib/Internal/Types/Dhall.hs
View File

@ -243,6 +243,7 @@ data Income = Income
, incFrom :: TaggedAcnt
, incToBal :: TaggedAcnt
, incPayPeriod :: !Period
, incPriority :: !Int
}
deriving instance Hashable HourlyPeriod

4
lib/Internal/Types/Main.hs
View File

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

16
lib/Internal/Utils.hs
View File

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