FIX separate running totals by budget label

This commit is contained in:
Nathan Dwarshuis 2023-07-04 10:35:11 -04:00
parent 8c9dc1e970
commit d9709f565f
6 changed files with 110 additions and 87 deletions

View File

@ -15,7 +15,7 @@ import RIO.Time
readBudget readBudget
:: (MonadInsertError m, MonadFinance m) :: (MonadInsertError m, MonadFinance m)
=> Budget => Budget
-> m (Either CommitR [Tx TxCommit]) -> m (Either CommitR [Tx CommitR])
readBudget readBudget
b@Budget b@Budget
{ bgtLabel { bgtLabel
@ -33,9 +33,8 @@ readBudget
Nothing -> return [] Nothing -> return []
Just budgetSpan -> do Just budgetSpan -> do
(intAllos, _) <- combineError intAlloRes acntRes (,) (intAllos, _) <- combineError intAlloRes acntRes (,)
let tc = BudgetCommit key bgtLabel let res1 = mapErrors (readIncome key bgtLabel intAllos budgetSpan) bgtIncomes
let res1 = mapErrors (readIncome tc intAllos budgetSpan) bgtIncomes let res2 = expandTransfers key bgtLabel budgetSpan bgtTransfers
let res2 = expandTransfers tc budgetSpan bgtTransfers
txs <- combineError (concat <$> res1) res2 (++) txs <- combineError (concat <$> res1) res2 (++)
shadow <- addShadowTransfers bgtShadowTransfers txs shadow <- addShadowTransfers bgtShadowTransfers txs
return $ txs ++ shadow return $ txs ++ shadow
@ -79,13 +78,15 @@ sortAllo a@Allocation {alloAmts = as} = do
-- loop into a fold which I don't feel like doing now :( -- loop into a fold which I don't feel like doing now :(
readIncome readIncome
:: (MonadInsertError m, MonadFinance m) :: (MonadInsertError m, MonadFinance m)
=> TxCommit => CommitR
-> T.Text
-> IntAllocations -> IntAllocations
-> DaySpan -> DaySpan
-> Income -> Income
-> m [Tx TxCommit] -> m [Tx CommitR]
readIncome readIncome
tc key
name
(intPre, intTax, intPost) (intPre, intTax, intPost)
ds ds
Income Income
@ -145,18 +146,19 @@ readIncome
(fromRational balance) (fromRational balance)
() ()
-- TODO make this into one large tx? -- TODO make this into one large tx?
allos <- mapErrors (allo2Trans tc day incFrom) (pre ++ tax ++ post) allos <- mapErrors (allo2Trans key name day incFrom) (pre ++ tax ++ post)
let bal = let bal =
Tx Tx
{ txCommit = tc { txCommit = key
, txDate = day , txDate = day
, txPrimary = Left primary , txPrimary = Left primary
, txOther = [] , txOther = []
, txDescr = "balance after deductions" , txDescr = "balance after deductions"
, txBudget = name
} }
-- TODO use real name here -- TODO use real name here
if balance < 0 if balance < 0
then throwError $ InsertException [IncomeError day "" balance] then throwError $ InsertException [IncomeError day name balance]
else return (bal : allos) else return (bal : allos)
periodScaler periodScaler
@ -259,12 +261,13 @@ selectAllos day Allocation {alloAmts, alloCur, alloTo} =
allo2Trans allo2Trans
:: (MonadInsertError m, MonadFinance m) :: (MonadInsertError m, MonadFinance m)
=> TxCommit => CommitR
-> T.Text
-> Day -> Day
-> TaggedAcnt -> TaggedAcnt
-> FlatAllocation Rational -> FlatAllocation Rational
-> m (Tx TxCommit) -> m (Tx CommitR)
allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} = do allo2Trans meta name day from FlatAllocation {faValue, faTo, faDesc, faCur} = do
-- TODO double here? -- TODO double here?
p <- entryPair from faTo faCur faDesc (fromRational faValue) () p <- entryPair from faTo faCur faDesc (fromRational faValue) ()
return return
@ -274,6 +277,7 @@ allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} = do
, txPrimary = Left p , txPrimary = Left p
, txOther = [] , txOther = []
, txDescr = faDesc , txDescr = faDesc
, txBudget = name
} }
allocatePre allocatePre
@ -351,8 +355,8 @@ allocatePost precision aftertax = fmap (fmap go)
addShadowTransfers addShadowTransfers
:: (MonadInsertError m, MonadFinance m) :: (MonadInsertError m, MonadFinance m)
=> [ShadowTransfer] => [ShadowTransfer]
-> [Tx TxCommit] -> [Tx CommitR]
-> m [Tx TxCommit] -> m [Tx CommitR]
addShadowTransfers ms = mapErrors go addShadowTransfers ms = mapErrors go
where where
go tx = do go tx = do
@ -361,7 +365,7 @@ addShadowTransfers ms = mapErrors go
fromShadow fromShadow
:: (MonadInsertError m, MonadFinance m) :: (MonadInsertError m, MonadFinance m)
=> Tx TxCommit => Tx CommitR
-> ShadowTransfer -> ShadowTransfer
-> m (Maybe ShadowEntrySet) -> m (Maybe ShadowEntrySet)
fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} = do fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} = do
@ -369,7 +373,7 @@ fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch
es <- entryPair stFrom stTo stCurrency stDesc stRatio () es <- entryPair stFrom stTo stCurrency stDesc stRatio ()
return $ if not res then Nothing else Just es return $ if not res then Nothing else Just es
shadowMatches :: TransferMatcher -> Tx TxCommit -> InsertExcept Bool shadowMatches :: TransferMatcher -> Tx CommitR -> InsertExcept Bool
shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} Tx {txPrimary, txDate} = do shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} Tx {txPrimary, txDate} = do
-- NOTE this will only match against the primary entry set since those -- NOTE this will only match against the primary entry set since those
-- are what are guaranteed to exist from a transfer -- are what are guaranteed to exist from a transfer

View File

@ -459,16 +459,17 @@ readUpdates hashes = do
( (
( entrysets ^. EntrySetRId ( entrysets ^. EntrySetRId
, txs ^. TransactionRDate , txs ^. TransactionRDate
, txs ^. TransactionRBudgetName
, entrysets ^. EntrySetRCurrency , entrysets ^. EntrySetRCurrency
) )
, entries , entries
) )
) )
let (toUpdate, toRead) = L.partition (E.unValue . fst) xs 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') return (makeRE . snd <$> toRead, toUpdate')
where where
makeUES ((_, day, curID), es) = do makeUES ((_, day, name, curID), es) = do
let res = let res =
bimap NE.nonEmpty NE.nonEmpty $ bimap NE.nonEmpty NE.nonEmpty $
NE.partition ((< 0) . entryRIndex . snd) $ NE.partition ((< 0) . entryRIndex . snd) $
@ -493,6 +494,7 @@ readUpdates hashes = do
, utFromUnk = fromUnk , utFromUnk = fromUnk
, utToUnk = toUnk , utToUnk = toUnk
, utTotalValue = tot , utTotalValue = tot
, utBudget = E.unValue name
} }
Right x -> Right x ->
Right $ Right $
@ -506,15 +508,17 @@ readUpdates hashes = do
, utFromUnk = fromUnk , utFromUnk = fromUnk
, utToUnk = toUnk , utToUnk = toUnk
, utTotalValue = () , utTotalValue = ()
, utBudget = E.unValue name
} }
_ -> throwError undefined _ -> throwError undefined
makeRE ((_, day, curID), entry) = makeRE ((_, day, name, curID), entry) =
let e = entityVal entry let e = entityVal entry
in ReadEntry in ReadEntry
{ reDate = E.unValue day { reDate = E.unValue day
, reCurrency = E.unValue curID , reCurrency = E.unValue curID
, reAcnt = entryRAccount e , reAcnt = entryRAccount e
, reValue = entryRValue e , reValue = entryRValue e
, reBudget = E.unValue name
} }
splitFrom splitFrom
@ -641,15 +645,16 @@ insertAll ebs = do
mapM_ updateTx toUpdate mapM_ updateTx toUpdate
forM_ (groupWith itxCommit toInsert) $ forM_ (groupWith itxCommit toInsert) $
\(c, ts) -> do \(c, ts) -> do
ck <- insert $ getCommit c ck <- insert c
mapM_ (insertTx ck) ts mapM_ (insertTx ck) ts
where
getCommit (HistoryCommit c) = c -- where
getCommit (BudgetCommit c _) = c -- getCommit (HistoryCommit c) = c
-- getCommit (BudgetCommit c _) = c
insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m () insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m ()
insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxCommit} = do insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxBudget} = do
k <- insert $ TransactionR c itxDate itxDescr k <- insert $ TransactionR c itxDate itxDescr itxBudget
mapM_ (uncurry (insertEntrySet k)) $ zip [0 ..] (NE.toList itxEntrySets) mapM_ (uncurry (insertEntrySet k)) $ zip [0 ..] (NE.toList itxEntrySets)
where where
insertEntrySet tk i InsertEntrySet {iesCurrency, iesFromEntries, iesToEntries} = do insertEntrySet tk i InsertEntrySet {iesCurrency, iesFromEntries, iesToEntries} = do
@ -658,11 +663,11 @@ insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxCommit} = do
let rebalance = any (isJust . ieDeferred) (fs ++ ts) let rebalance = any (isJust . ieDeferred) (fs ++ ts)
esk <- insert $ EntrySetR tk iesCurrency i rebalance esk <- insert $ EntrySetR tk iesCurrency i rebalance
mapM_ (uncurry (go esk)) $ zip [0 ..] ts ++ zip (negate <$> [1 ..]) fs mapM_ (uncurry (go esk)) $ zip [0 ..] ts ++ zip (negate <$> [1 ..]) fs
go k i e = do go k i e = void $ insertEntry k i e
ek <- insertEntry k i e
case itxCommit of -- case itxCommit of
BudgetCommit _ name -> insert_ $ BudgetLabelR ek name -- BudgetCommit _ name -> insert_ $ BudgetLabelR ek name
_ -> return () -- _ -> return ()
insertEntry :: MonadSqlQuery m => EntrySetRId -> Int -> KeyEntry -> m EntryRId insertEntry :: MonadSqlQuery m => EntrySetRId -> Int -> KeyEntry -> m EntryRId
insertEntry insertEntry

View File

@ -38,10 +38,10 @@ splitHistory = partitionEithers . fmap go
readHistTransfer readHistTransfer
:: (MonadInsertError m, MonadFinance m) :: (MonadInsertError m, MonadFinance m)
=> PairedTransfer => PairedTransfer
-> m (Either CommitR [Tx TxCommit]) -> m (Either CommitR [Tx CommitR])
readHistTransfer ht = eitherHash CTManual ht return $ \c -> do readHistTransfer ht = eitherHash CTManual ht return $ \c -> do
bounds <- askDBState kmStatementInterval bounds <- askDBState kmStatementInterval
expandTransfer (HistoryCommit c) bounds ht expandTransfer c historyName bounds ht
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Statements -- Statements
@ -50,11 +50,11 @@ readHistStmt
:: (MonadUnliftIO m, MonadFinance m) :: (MonadUnliftIO m, MonadFinance m)
=> FilePath => FilePath
-> Statement -> Statement
-> m (Either CommitR [Tx TxCommit]) -> m (Either CommitR [Tx CommitR])
readHistStmt root i = eitherHash CTImport i return $ \c -> do readHistStmt root i = eitherHash CTImport i return $ \c -> do
bs <- readImport root i bs <- readImport root i
bounds <- askDBState kmStatementInterval bounds <- askDBState kmStatementInterval
return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = HistoryCommit c}) bs return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs
-- TODO this probably won't scale well (pipes?) -- TODO this probably won't scale well (pipes?)
readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [Tx ()] readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [Tx ()]
@ -306,6 +306,7 @@ toTx
, esTo = t , esTo = t
} }
, txOther = fmap Left ss , txOther = fmap Left ss
, txBudget = historyName
} }
where where
curRes = do curRes = do
@ -502,3 +503,6 @@ parseRational (pat, re) s = case matchGroupsMaybe s re of
w <- readT "whole number" x w <- readT "whole number" x
k <- readSign sign k <- readSign sign
return (k, w) return (k, w)
historyName :: T.Text
historyName = "history"

View File

@ -44,6 +44,7 @@ TransactionR sql=transactions
commit CommitRId OnDeleteCascade commit CommitRId OnDeleteCascade
date Day date Day
description T.Text description T.Text
budgetName T.Text
deriving Show Eq deriving Show Eq
EntrySetR sql=entry_sets EntrySetR sql=entry_sets
transaction TransactionRId OnDeleteCascade transaction TransactionRId OnDeleteCascade
@ -65,10 +66,6 @@ TagRelationR sql=tag_relations
entry EntryRId OnDeleteCascade entry EntryRId OnDeleteCascade
tag TagRId OnDeleteCascade tag TagRId OnDeleteCascade
deriving Show Eq deriving Show Eq
BudgetLabelR sql=budget_labels
entry EntryRId OnDeleteCascade
budgetName T.Text
deriving Show Eq
|] |]
data ConfigType = CTBudget | CTManual | CTImport data ConfigType = CTBudget | CTManual | CTImport

View File

@ -75,6 +75,7 @@ data ReadEntry = ReadEntry
, reAcnt :: !AccountRId , reAcnt :: !AccountRId
, reValue :: !Rational , reValue :: !Rational
, reDate :: !Day , reDate :: !Day
, reBudget :: !T.Text
} }
deriving (Show) deriving (Show)
@ -121,6 +122,7 @@ data UpdateEntrySet f t = UpdateEntrySet
, utCurrency :: !CurrencyRId , utCurrency :: !CurrencyRId
, utDate :: !Day , utDate :: !Day
, utTotalValue :: !t , utTotalValue :: !t
, utBudget :: !T.Text
} }
deriving (Show) deriving (Show)
@ -131,16 +133,12 @@ type FullUpdateEntrySet = UpdateEntrySet (Either UE_RO (UEUnk, [UELink])) ()
data EntryBin data EntryBin
= ToUpdate (Either TotalUpdateEntrySet FullUpdateEntrySet) = ToUpdate (Either TotalUpdateEntrySet FullUpdateEntrySet)
| ToRead ReadEntry | ToRead ReadEntry
| ToInsert (Tx TxCommit) | ToInsert (Tx CommitR)
type KeyEntry = InsertEntry AccountRId CurrencyRId TagRId type KeyEntry = InsertEntry AccountRId CurrencyRId TagRId
type BalEntry = InsertEntry AcntID CurID TagID type BalEntry = InsertEntry AcntID CurID TagID
-- type DeferredKeyTx = Tx DeferredKeyEntry
-- type KeyTx = Tx KeyEntry
type TreeR = Tree ([T.Text], AccountRId) type TreeR = Tree ([T.Text], AccountRId)
type MonadFinance = MonadReader DBState type MonadFinance = MonadReader DBState
@ -253,6 +251,7 @@ data Tx k = Tx
, txPrimary :: !(Either PrimaryEntrySet TransferEntrySet) , txPrimary :: !(Either PrimaryEntrySet TransferEntrySet)
, txOther :: ![Either SecondayEntrySet ShadowEntrySet] , txOther :: ![Either SecondayEntrySet ShadowEntrySet]
, txCommit :: !k , txCommit :: !k
, txBudget :: !T.Text
} }
deriving (Generic, Show) deriving (Generic, Show)
@ -271,7 +270,8 @@ data InsertTx = InsertTx
{ itxDescr :: !T.Text { itxDescr :: !T.Text
, itxDate :: !Day , itxDate :: !Day
, itxEntrySets :: !(NonEmpty InsertEntrySet) , itxEntrySets :: !(NonEmpty InsertEntrySet)
, itxCommit :: !TxCommit , itxCommit :: !CommitR
, itxBudget :: !T.Text
} }
deriving (Generic) deriving (Generic)

View File

@ -677,6 +677,7 @@ lookupFinance
-> m a -> m a
lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f
-- TODO need to split out the balance map by budget name (epic facepalm)
balanceTxs balanceTxs
:: (MonadInsertError m, MonadFinance m) :: (MonadInsertError m, MonadFinance m)
=> [EntryBin] => [EntryBin]
@ -689,19 +690,21 @@ balanceTxs ebs =
fmap (Just . Left) $ fmap (Just . Left) $
liftInnerS $ liftInnerS $
either rebalanceTotalEntrySet rebalanceFullEntrySet utx either rebalanceTotalEntrySet rebalanceFullEntrySet utx
go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do go (ToRead ReadEntry {reCurrency, reAcnt, reValue, reBudget}) = do
modify $ mapAdd_ (reAcnt, reCurrency) reValue modify $ mapAdd_ (reAcnt, reCurrency, reBudget) reValue
return Nothing return Nothing
go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate}) = do go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate, txBudget}) = do
e <- either balancePrimaryEntrySet balanceSecondaryEntrySet txPrimary e <- either (balancePrimaryEntrySet txBudget) (balanceSecondaryEntrySet txBudget) txPrimary
let tot = sum $ fmap (eValue . ieEntry) $ NE.toList $ iesFromEntries e let tot = sum $ fmap (eValue . ieEntry) $ NE.toList $ iesFromEntries e
es <- mapErrors (either balanceSecondaryEntrySet (balancePrimaryEntrySet . fromShadow tot)) txOther es <- mapErrors (either (balanceSecondaryEntrySet txBudget) (balancePrimaryEntrySet txBudget . fromShadow tot)) txOther
let tx = let tx =
-- TODO this is lame
InsertTx InsertTx
{ itxDescr = txDescr { itxDescr = txDescr
, itxDate = txDate , itxDate = txDate
, itxEntrySets = e :| es , itxEntrySets = e :| es
, itxCommit = txCommit , itxCommit = txCommit
, itxBudget = txBudget
} }
return $ Just $ Right tx return $ Just $ Right tx
fromShadow tot e@EntrySet {esTotalValue} = e {esTotalValue = tot * toRational esTotalValue} fromShadow tot e@EntrySet {esTotalValue} = e {esTotalValue = tot * toRational esTotalValue}
@ -712,7 +715,7 @@ binDate (ToUpdate (Left UpdateEntrySet {utDate})) = utDate
binDate (ToRead ReadEntry {reDate}) = reDate binDate (ToRead ReadEntry {reDate}) = reDate
binDate (ToInsert Tx {txDate}) = txDate binDate (ToInsert Tx {txDate}) = txDate
type EntryBals = M.Map (AccountRId, CurrencyRId) Rational type EntryBals = M.Map (AccountRId, CurrencyRId, Text) Rational
data UpdateEntryType a b data UpdateEntryType a b
= UET_ReadOnly UE_RO = UET_ReadOnly UE_RO
@ -725,14 +728,13 @@ rebalanceTotalEntrySet
UpdateEntrySet UpdateEntrySet
{ utFrom0 = (f0, f0links) { utFrom0 = (f0, f0links)
, utTo0 , utTo0
, -- , utPairs , utFromUnk
utFromUnk
, utToUnk , utToUnk
, utFromRO , utFromRO
, utToRO , utToRO
, utCurrency , utCurrency
, -- , utToUnkLink0 , utTotalValue
utTotalValue , utBudget
} = } =
do do
(f0val, (tpairs, fs)) <- (f0val, (tpairs, fs)) <-
@ -782,10 +784,10 @@ rebalanceTotalEntrySet
updateFixed :: UpdateEntry i StaticValue -> State EntryBals Rational updateFixed :: UpdateEntry i StaticValue -> State EntryBals Rational
updateFixed e = do updateFixed e = do
let v = unStaticValue $ ueValue e let v = unStaticValue $ ueValue e
modify $ mapAdd_ (ueAcnt e, utCurrency) v modify $ mapAdd_ (ueAcnt e, utCurrency, utBudget) v
return v return v
updateUnknown e = do updateUnknown e = do
let key = (ueAcnt e, utCurrency) let key = (ueAcnt e, utCurrency, utBudget)
curBal <- gets (M.findWithDefault 0 key) curBal <- gets (M.findWithDefault 0 key)
let v = case ueValue e of let v = case ueValue e of
EVPercent p -> p * curBal EVPercent p -> p * curBal
@ -799,13 +801,12 @@ rebalanceFullEntrySet
UpdateEntrySet UpdateEntrySet
{ utFrom0 { utFrom0
, utTo0 , utTo0
, -- , utPairs , utFromUnk
utFromUnk
, utToUnk , utToUnk
, utFromRO , utFromRO
, utToRO , utToRO
, utCurrency , utCurrency
-- , utToUnkLink0 , utBudget
} = } =
do do
let (f_ro, f_lnkd) = case utFrom0 of let (f_ro, f_lnkd) = case utFrom0 of
@ -857,10 +858,10 @@ rebalanceFullEntrySet
updateFixed :: UpdateEntry i StaticValue -> State EntryBals Rational updateFixed :: UpdateEntry i StaticValue -> State EntryBals Rational
updateFixed e = do updateFixed e = do
let v = unStaticValue $ ueValue e let v = unStaticValue $ ueValue e
modify $ mapAdd_ (ueAcnt e, utCurrency) v modify $ mapAdd_ (ueAcnt e, utCurrency, utBudget) v
return v return v
updateUnknown e = do updateUnknown e = do
let key = (ueAcnt e, utCurrency) let key = (ueAcnt e, utCurrency, utBudget)
curBal <- gets (M.findWithDefault 0 key) curBal <- gets (M.findWithDefault 0 key)
let v = case ueValue e of let v = case ueValue e of
EVPercent p -> p * curBal EVPercent p -> p * curBal
@ -872,9 +873,11 @@ rebalanceFullEntrySet
balanceSecondaryEntrySet balanceSecondaryEntrySet
:: (MonadInsertError m, MonadFinance m) :: (MonadInsertError m, MonadFinance m)
=> SecondayEntrySet => T.Text
-> SecondayEntrySet
-> StateT EntryBals m InsertEntrySet -> StateT EntryBals m InsertEntrySet
balanceSecondaryEntrySet balanceSecondaryEntrySet
budgetName
EntrySet EntrySet
{ esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs} { esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
, esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts} , esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
@ -884,15 +887,15 @@ balanceSecondaryEntrySet
fs' <- mapErrors resolveAcntAndTags (f0 :| fs) fs' <- mapErrors resolveAcntAndTags (f0 :| fs)
t0' <- resolveAcntAndTags t0 t0' <- resolveAcntAndTags t0
ts' <- mapErrors resolveAcntAndTags ts ts' <- mapErrors resolveAcntAndTags ts
let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a) curID let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a budgetName) curID budgetName
fs'' <- mapErrors balFromEntry fs' fs'' <- mapErrors balFromEntry fs'
let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs'' let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs''
let balToEntry = balanceEntry (balanceLinked fv curID precision) curID let balToEntry = balanceEntry (balanceLinked fv curID budgetName precision) curID budgetName
ts'' <- mapErrors balToEntry ts' ts'' <- mapErrors balToEntry ts'
-- TODO wet -- TODO wet
let (acntID, sign) = eAcnt t0' let (acntID, sign) = eAcnt t0'
let t0Val = -(entrySum (NE.toList fs'') + entrySum ts'') let t0Val = -(entrySum (NE.toList fs'') + entrySum ts'')
modify (mapAdd_ (acntID, curID) t0Val) modify (mapAdd_ (acntID, curID, budgetName) t0Val)
let t0'' = let t0'' =
InsertEntry InsertEntry
{ ieEntry = t0' {eValue = fromIntegral (sign2Int sign) * t0Val, eAcnt = acntID} { ieEntry = t0' {eValue = fromIntegral (sign2Int sign) * t0Val, eAcnt = acntID}
@ -911,9 +914,11 @@ balanceSecondaryEntrySet
balancePrimaryEntrySet balancePrimaryEntrySet
:: (MonadInsertError m, MonadFinance m) :: (MonadInsertError m, MonadFinance m)
=> PrimaryEntrySet => T.Text
-> PrimaryEntrySet
-> StateT EntryBals m InsertEntrySet -> StateT EntryBals m InsertEntrySet
balancePrimaryEntrySet balancePrimaryEntrySet
budgetName
EntrySet EntrySet
{ esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs} { esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
, esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts} , esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
@ -927,13 +932,13 @@ balancePrimaryEntrySet
let tsres = mapErrors resolveAcntAndTags ts let tsres = mapErrors resolveAcntAndTags ts
combineErrorM (combineError f0res fsres (,)) (combineError t0res tsres (,)) $ combineErrorM (combineError f0res fsres (,)) (combineError t0res tsres (,)) $
\(f0', fs') (t0', ts') -> do \(f0', fs') (t0', ts') -> do
let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a) curID let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a budgetName) curID budgetName
fs'' <- doEntries balFromEntry curID esTotalValue f0' fs' fs'' <- doEntries balFromEntry curID budgetName esTotalValue f0' fs'
let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs'' let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs''
let balToEntry = balanceEntry (balanceLinked fv curID precision) curID let balToEntry = balanceEntry (balanceLinked fv curID budgetName precision) curID budgetName
ts'' <- doEntries balToEntry curID (-esTotalValue) t0' ts' ts'' <- doEntries balToEntry curID budgetName (-esTotalValue) t0' ts'
return $ return $
InsertEntrySet InsertEntrySet
{ iesCurrency = curID { iesCurrency = curID
@ -945,16 +950,17 @@ doEntries
:: (MonadInsertError m) :: (MonadInsertError m)
=> (Entry (AccountRId, AcntSign) v TagRId -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId)) => (Entry (AccountRId, AcntSign) v TagRId -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId))
-> CurrencyRId -> CurrencyRId
-> T.Text
-> Rational -> Rational
-> Entry (AccountRId, AcntSign) () TagRId -> Entry (AccountRId, AcntSign) () TagRId
-> [Entry (AccountRId, AcntSign) v TagRId] -> [Entry (AccountRId, AcntSign) v TagRId]
-> StateT EntryBals m (NonEmpty (InsertEntry AccountRId CurrencyRId TagRId)) -> StateT EntryBals m (NonEmpty (InsertEntry AccountRId CurrencyRId TagRId))
doEntries f curID tot e@Entry {eAcnt = (acntID, sign)} es = do doEntries f curID budgetName tot e@Entry {eAcnt = (acntID, sign)} es = do
es' <- mapErrors f es es' <- mapErrors f es
let e0val = tot - entrySum es' let e0val = tot - entrySum es'
-- TODO not dry -- TODO not dry
let s = fromIntegral $ sign2Int sign -- NOTE hack let s = fromIntegral $ sign2Int sign -- NOTE hack
modify (mapAdd_ (acntID, curID) e0val) modify (mapAdd_ (acntID, curID, budgetName) e0val)
let e' = let e' =
InsertEntry InsertEntry
{ ieEntry = e {eValue = s * e0val, eAcnt = acntID} { ieEntry = e {eValue = s * e0val, eAcnt = acntID}
@ -971,11 +977,12 @@ balanceLinked
:: MonadInsertError m :: MonadInsertError m
=> Vector Rational => Vector Rational
-> CurrencyRId -> CurrencyRId
-> T.Text
-> Natural -> Natural
-> AccountRId -> AccountRId
-> LinkDeferred Rational -> LinkDeferred Rational
-> StateT EntryBals m (Rational, Maybe DBDeferred) -> StateT EntryBals m (Rational, Maybe DBDeferred)
balanceLinked from curID precision acntID lg = case lg of balanceLinked from curID budgetName precision acntID lg = case lg of
(LinkIndex LinkedNumGetter {lngIndex, lngScale}) -> do (LinkIndex LinkedNumGetter {lngIndex, lngScale}) -> do
let res = fmap (go lngScale) $ from V.!? fromIntegral lngIndex let res = fmap (go lngScale) $ from V.!? fromIntegral lngIndex
case res of case res of
@ -983,17 +990,18 @@ balanceLinked from curID precision acntID lg = case lg of
-- TODO this error would be much more informative if I had access to the -- TODO this error would be much more informative if I had access to the
-- file from which it came -- file from which it came
Nothing -> throwError undefined Nothing -> throwError undefined
(LinkDeferred d) -> liftInnerS $ balanceDeferred curID acntID d (LinkDeferred d) -> liftInnerS $ balanceDeferred curID acntID budgetName d
where where
go s = negate . roundPrecision precision . (* s) . fromRational go s = negate . roundPrecision precision . (* s) . fromRational
balanceDeferred balanceDeferred
:: CurrencyRId :: CurrencyRId
-> AccountRId -> AccountRId
-> T.Text
-> EntryValue Rational -> EntryValue Rational
-> State EntryBals (Rational, Maybe DBDeferred) -> State EntryBals (Rational, Maybe DBDeferred)
balanceDeferred curID acntID (EntryValue t v) = do balanceDeferred curID acntID budgetName (EntryValue t v) = do
newval <- findBalance acntID curID t v newval <- findBalance acntID curID budgetName t v
let d = case t of let d = case t of
TFixed -> Nothing TFixed -> Nothing
TBalance -> Just $ EntryBalance v TBalance -> Just $ EntryBalance v
@ -1004,12 +1012,13 @@ balanceEntry
:: (MonadInsertError m) :: (MonadInsertError m)
=> (AccountRId -> v -> StateT EntryBals m (Rational, Maybe DBDeferred)) => (AccountRId -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
-> CurrencyRId -> CurrencyRId
-> T.Text
-> Entry (AccountRId, AcntSign) v TagRId -> Entry (AccountRId, AcntSign) v TagRId
-> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId) -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId)
balanceEntry f curID e@Entry {eValue, eAcnt = (acntID, sign)} = do balanceEntry f curID budgetName e@Entry {eValue, eAcnt = (acntID, sign)} = do
let s = fromIntegral $ sign2Int sign let s = fromIntegral $ sign2Int sign
(newVal, deferred) <- f acntID eValue (newVal, deferred) <- f acntID eValue
modify (mapAdd_ (acntID, curID) newVal) modify (mapAdd_ (acntID, curID, budgetName) newVal)
return $ return $
InsertEntry InsertEntry
{ ieEntry = e {eValue = s * newVal, eAcnt = acntID} { ieEntry = e {eValue = s * newVal, eAcnt = acntID}
@ -1029,11 +1038,12 @@ resolveAcntAndTags e@Entry {eAcnt, eTags} = do
findBalance findBalance
:: AccountRId :: AccountRId
-> CurrencyRId -> CurrencyRId
-> T.Text
-> TransferType -> TransferType
-> Rational -> Rational
-> State EntryBals Rational -> State EntryBals Rational
findBalance acnt cur t v = do findBalance acnt cur name t v = do
curBal <- gets (M.findWithDefault 0 (acnt, cur)) curBal <- gets (M.findWithDefault 0 (acnt, cur, name))
return $ case t of return $ case t of
TBalance -> v - curBal TBalance -> v - curBal
TPercent -> v * curBal TPercent -> v * curBal
@ -1041,19 +1051,21 @@ findBalance acnt cur t v = do
expandTransfers expandTransfers
:: (MonadInsertError m, MonadFinance m) :: (MonadInsertError m, MonadFinance m)
=> TxCommit => CommitR
-> T.Text
-> DaySpan -> DaySpan
-> [PairedTransfer] -> [PairedTransfer]
-> m [Tx TxCommit] -> m [Tx CommitR]
expandTransfers tc bounds = fmap concat . mapErrors (expandTransfer tc bounds) expandTransfers tc name bounds = fmap concat . mapErrors (expandTransfer tc name bounds)
expandTransfer expandTransfer
:: (MonadInsertError m, MonadFinance m) :: (MonadInsertError m, MonadFinance m)
=> TxCommit => CommitR
-> T.Text
-> DaySpan -> DaySpan
-> PairedTransfer -> PairedTransfer
-> m [Tx TxCommit] -> m [Tx CommitR]
expandTransfer tc bounds Transfer {transAmounts, transTo, transCurrency, transFrom} = do expandTransfer tc name bounds Transfer {transAmounts, transTo, transCurrency, transFrom} = do
txs <- mapErrors go transAmounts txs <- mapErrors go transAmounts
return $ concat txs return $ concat txs
where where
@ -1072,6 +1084,7 @@ expandTransfer tc bounds Transfer {transAmounts, transTo, transCurrency, transFr
, txPrimary = Right p , txPrimary = Right p
, txOther = [] , txOther = []
, txDescr = desc , txDescr = desc
, txBudget = name
} }
entryPair entryPair