FIX separate running totals by budget label
This commit is contained in:
parent
8c9dc1e970
commit
d9709f565f
|
|
@ -15,7 +15,7 @@ import RIO.Time
|
|||
readBudget
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> Budget
|
||||
-> m (Either CommitR [Tx TxCommit])
|
||||
-> m (Either CommitR [Tx CommitR])
|
||||
readBudget
|
||||
b@Budget
|
||||
{ bgtLabel
|
||||
|
|
@ -33,9 +33,8 @@ readBudget
|
|||
Nothing -> return []
|
||||
Just budgetSpan -> do
|
||||
(intAllos, _) <- combineError intAlloRes acntRes (,)
|
||||
let tc = BudgetCommit key bgtLabel
|
||||
let res1 = mapErrors (readIncome tc intAllos budgetSpan) bgtIncomes
|
||||
let res2 = expandTransfers tc budgetSpan bgtTransfers
|
||||
let res1 = mapErrors (readIncome key bgtLabel intAllos budgetSpan) bgtIncomes
|
||||
let res2 = expandTransfers key bgtLabel budgetSpan bgtTransfers
|
||||
txs <- combineError (concat <$> res1) res2 (++)
|
||||
shadow <- addShadowTransfers bgtShadowTransfers txs
|
||||
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 :(
|
||||
readIncome
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> TxCommit
|
||||
=> CommitR
|
||||
-> T.Text
|
||||
-> IntAllocations
|
||||
-> DaySpan
|
||||
-> Income
|
||||
-> m [Tx TxCommit]
|
||||
-> m [Tx CommitR]
|
||||
readIncome
|
||||
tc
|
||||
key
|
||||
name
|
||||
(intPre, intTax, intPost)
|
||||
ds
|
||||
Income
|
||||
|
|
@ -145,18 +146,19 @@ readIncome
|
|||
(fromRational balance)
|
||||
()
|
||||
-- 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 =
|
||||
Tx
|
||||
{ txCommit = tc
|
||||
{ txCommit = key
|
||||
, txDate = day
|
||||
, txPrimary = Left primary
|
||||
, txOther = []
|
||||
, txDescr = "balance after deductions"
|
||||
, txBudget = name
|
||||
}
|
||||
-- TODO use real name here
|
||||
if balance < 0
|
||||
then throwError $ InsertException [IncomeError day "" balance]
|
||||
then throwError $ InsertException [IncomeError day name balance]
|
||||
else return (bal : allos)
|
||||
|
||||
periodScaler
|
||||
|
|
@ -259,12 +261,13 @@ selectAllos day Allocation {alloAmts, alloCur, alloTo} =
|
|||
|
||||
allo2Trans
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> TxCommit
|
||||
=> CommitR
|
||||
-> T.Text
|
||||
-> Day
|
||||
-> TaggedAcnt
|
||||
-> FlatAllocation Rational
|
||||
-> m (Tx TxCommit)
|
||||
allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} = do
|
||||
-> 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
|
||||
|
|
@ -274,6 +277,7 @@ allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} = do
|
|||
, txPrimary = Left p
|
||||
, txOther = []
|
||||
, txDescr = faDesc
|
||||
, txBudget = name
|
||||
}
|
||||
|
||||
allocatePre
|
||||
|
|
@ -351,8 +355,8 @@ allocatePost precision aftertax = fmap (fmap go)
|
|||
addShadowTransfers
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> [ShadowTransfer]
|
||||
-> [Tx TxCommit]
|
||||
-> m [Tx TxCommit]
|
||||
-> [Tx CommitR]
|
||||
-> m [Tx CommitR]
|
||||
addShadowTransfers ms = mapErrors go
|
||||
where
|
||||
go tx = do
|
||||
|
|
@ -361,7 +365,7 @@ addShadowTransfers ms = mapErrors go
|
|||
|
||||
fromShadow
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> Tx TxCommit
|
||||
=> Tx CommitR
|
||||
-> ShadowTransfer
|
||||
-> m (Maybe ShadowEntrySet)
|
||||
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 ()
|
||||
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
|
||||
-- NOTE this will only match against the primary entry set since those
|
||||
-- are what are guaranteed to exist from a transfer
|
||||
|
|
|
|||
|
|
@ -459,16 +459,17 @@ readUpdates hashes = do
|
|||
(
|
||||
( entrysets ^. EntrySetRId
|
||||
, txs ^. TransactionRDate
|
||||
, txs ^. TransactionRBudgetName
|
||||
, entrysets ^. EntrySetRCurrency
|
||||
)
|
||||
, entries
|
||||
)
|
||||
)
|
||||
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, curID), es) = do
|
||||
makeUES ((_, day, name, curID), es) = do
|
||||
let res =
|
||||
bimap NE.nonEmpty NE.nonEmpty $
|
||||
NE.partition ((< 0) . entryRIndex . snd) $
|
||||
|
|
@ -493,6 +494,7 @@ readUpdates hashes = do
|
|||
, utFromUnk = fromUnk
|
||||
, utToUnk = toUnk
|
||||
, utTotalValue = tot
|
||||
, utBudget = E.unValue name
|
||||
}
|
||||
Right x ->
|
||||
Right $
|
||||
|
|
@ -506,15 +508,17 @@ readUpdates hashes = do
|
|||
, utFromUnk = fromUnk
|
||||
, utToUnk = toUnk
|
||||
, utTotalValue = ()
|
||||
, utBudget = E.unValue name
|
||||
}
|
||||
_ -> throwError undefined
|
||||
makeRE ((_, day, curID), entry) =
|
||||
makeRE ((_, day, name, curID), entry) =
|
||||
let e = entityVal entry
|
||||
in ReadEntry
|
||||
{ reDate = E.unValue day
|
||||
, reCurrency = E.unValue curID
|
||||
, reAcnt = entryRAccount e
|
||||
, reValue = entryRValue e
|
||||
, reBudget = E.unValue name
|
||||
}
|
||||
|
||||
splitFrom
|
||||
|
|
@ -641,15 +645,16 @@ insertAll ebs = do
|
|||
mapM_ updateTx toUpdate
|
||||
forM_ (groupWith itxCommit toInsert) $
|
||||
\(c, ts) -> do
|
||||
ck <- insert $ getCommit c
|
||||
ck <- insert c
|
||||
mapM_ (insertTx ck) ts
|
||||
where
|
||||
getCommit (HistoryCommit c) = c
|
||||
getCommit (BudgetCommit c _) = c
|
||||
|
||||
-- where
|
||||
-- getCommit (HistoryCommit c) = c
|
||||
-- getCommit (BudgetCommit c _) = c
|
||||
|
||||
insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m ()
|
||||
insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxCommit} = do
|
||||
k <- insert $ TransactionR c itxDate itxDescr
|
||||
insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxBudget} = do
|
||||
k <- insert $ TransactionR c itxDate itxDescr itxBudget
|
||||
mapM_ (uncurry (insertEntrySet k)) $ zip [0 ..] (NE.toList itxEntrySets)
|
||||
where
|
||||
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)
|
||||
esk <- insert $ EntrySetR tk iesCurrency i rebalance
|
||||
mapM_ (uncurry (go esk)) $ zip [0 ..] ts ++ zip (negate <$> [1 ..]) fs
|
||||
go k i e = do
|
||||
ek <- insertEntry k i e
|
||||
case itxCommit of
|
||||
BudgetCommit _ name -> insert_ $ BudgetLabelR ek name
|
||||
_ -> return ()
|
||||
go k i e = void $ insertEntry k i e
|
||||
|
||||
-- case itxCommit of
|
||||
-- BudgetCommit _ name -> insert_ $ BudgetLabelR ek name
|
||||
-- _ -> return ()
|
||||
|
||||
insertEntry :: MonadSqlQuery m => EntrySetRId -> Int -> KeyEntry -> m EntryRId
|
||||
insertEntry
|
||||
|
|
|
|||
|
|
@ -38,10 +38,10 @@ splitHistory = partitionEithers . fmap go
|
|||
readHistTransfer
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> PairedTransfer
|
||||
-> m (Either CommitR [Tx TxCommit])
|
||||
-> m (Either CommitR [Tx CommitR])
|
||||
readHistTransfer ht = eitherHash CTManual ht return $ \c -> do
|
||||
bounds <- askDBState kmStatementInterval
|
||||
expandTransfer (HistoryCommit c) bounds ht
|
||||
expandTransfer c historyName bounds ht
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Statements
|
||||
|
|
@ -50,11 +50,11 @@ readHistStmt
|
|||
:: (MonadUnliftIO m, MonadFinance m)
|
||||
=> FilePath
|
||||
-> Statement
|
||||
-> m (Either CommitR [Tx TxCommit])
|
||||
-> m (Either CommitR [Tx CommitR])
|
||||
readHistStmt root i = eitherHash CTImport i return $ \c -> do
|
||||
bs <- readImport root i
|
||||
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?)
|
||||
readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [Tx ()]
|
||||
|
|
@ -306,6 +306,7 @@ toTx
|
|||
, esTo = t
|
||||
}
|
||||
, txOther = fmap Left ss
|
||||
, txBudget = historyName
|
||||
}
|
||||
where
|
||||
curRes = do
|
||||
|
|
@ -502,3 +503,6 @@ parseRational (pat, re) s = case matchGroupsMaybe s re of
|
|||
w <- readT "whole number" x
|
||||
k <- readSign sign
|
||||
return (k, w)
|
||||
|
||||
historyName :: T.Text
|
||||
historyName = "history"
|
||||
|
|
|
|||
|
|
@ -44,6 +44,7 @@ TransactionR sql=transactions
|
|||
commit CommitRId OnDeleteCascade
|
||||
date Day
|
||||
description T.Text
|
||||
budgetName T.Text
|
||||
deriving Show Eq
|
||||
EntrySetR sql=entry_sets
|
||||
transaction TransactionRId OnDeleteCascade
|
||||
|
|
@ -65,10 +66,6 @@ TagRelationR sql=tag_relations
|
|||
entry EntryRId OnDeleteCascade
|
||||
tag TagRId OnDeleteCascade
|
||||
deriving Show Eq
|
||||
BudgetLabelR sql=budget_labels
|
||||
entry EntryRId OnDeleteCascade
|
||||
budgetName T.Text
|
||||
deriving Show Eq
|
||||
|]
|
||||
|
||||
data ConfigType = CTBudget | CTManual | CTImport
|
||||
|
|
|
|||
|
|
@ -75,6 +75,7 @@ data ReadEntry = ReadEntry
|
|||
, reAcnt :: !AccountRId
|
||||
, reValue :: !Rational
|
||||
, reDate :: !Day
|
||||
, reBudget :: !T.Text
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
|
|
@ -121,6 +122,7 @@ data UpdateEntrySet f t = UpdateEntrySet
|
|||
, utCurrency :: !CurrencyRId
|
||||
, utDate :: !Day
|
||||
, utTotalValue :: !t
|
||||
, utBudget :: !T.Text
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
|
|
@ -131,16 +133,12 @@ type FullUpdateEntrySet = UpdateEntrySet (Either UE_RO (UEUnk, [UELink])) ()
|
|||
data EntryBin
|
||||
= ToUpdate (Either TotalUpdateEntrySet FullUpdateEntrySet)
|
||||
| ToRead ReadEntry
|
||||
| ToInsert (Tx TxCommit)
|
||||
| ToInsert (Tx CommitR)
|
||||
|
||||
type KeyEntry = InsertEntry AccountRId CurrencyRId TagRId
|
||||
|
||||
type BalEntry = InsertEntry AcntID CurID TagID
|
||||
|
||||
-- type DeferredKeyTx = Tx DeferredKeyEntry
|
||||
|
||||
-- type KeyTx = Tx KeyEntry
|
||||
|
||||
type TreeR = Tree ([T.Text], AccountRId)
|
||||
|
||||
type MonadFinance = MonadReader DBState
|
||||
|
|
@ -253,6 +251,7 @@ data Tx k = Tx
|
|||
, txPrimary :: !(Either PrimaryEntrySet TransferEntrySet)
|
||||
, txOther :: ![Either SecondayEntrySet ShadowEntrySet]
|
||||
, txCommit :: !k
|
||||
, txBudget :: !T.Text
|
||||
}
|
||||
deriving (Generic, Show)
|
||||
|
||||
|
|
@ -271,7 +270,8 @@ data InsertTx = InsertTx
|
|||
{ itxDescr :: !T.Text
|
||||
, itxDate :: !Day
|
||||
, itxEntrySets :: !(NonEmpty InsertEntrySet)
|
||||
, itxCommit :: !TxCommit
|
||||
, itxCommit :: !CommitR
|
||||
, itxBudget :: !T.Text
|
||||
}
|
||||
deriving (Generic)
|
||||
|
||||
|
|
|
|||
|
|
@ -677,6 +677,7 @@ lookupFinance
|
|||
-> m a
|
||||
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
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> [EntryBin]
|
||||
|
|
@ -689,19 +690,21 @@ balanceTxs ebs =
|
|||
fmap (Just . Left) $
|
||||
liftInnerS $
|
||||
either rebalanceTotalEntrySet rebalanceFullEntrySet utx
|
||||
go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do
|
||||
modify $ mapAdd_ (reAcnt, reCurrency) reValue
|
||||
go (ToRead ReadEntry {reCurrency, reAcnt, reValue, reBudget}) = do
|
||||
modify $ mapAdd_ (reAcnt, reCurrency, reBudget) reValue
|
||||
return Nothing
|
||||
go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate}) = do
|
||||
e <- either balancePrimaryEntrySet balanceSecondaryEntrySet txPrimary
|
||||
go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate, txBudget}) = do
|
||||
e <- either (balancePrimaryEntrySet txBudget) (balanceSecondaryEntrySet txBudget) txPrimary
|
||||
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 =
|
||||
-- TODO this is lame
|
||||
InsertTx
|
||||
{ itxDescr = txDescr
|
||||
, itxDate = txDate
|
||||
, itxEntrySets = e :| es
|
||||
, itxCommit = txCommit
|
||||
, itxBudget = txBudget
|
||||
}
|
||||
return $ Just $ Right tx
|
||||
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 (ToInsert Tx {txDate}) = txDate
|
||||
|
||||
type EntryBals = M.Map (AccountRId, CurrencyRId) Rational
|
||||
type EntryBals = M.Map (AccountRId, CurrencyRId, Text) Rational
|
||||
|
||||
data UpdateEntryType a b
|
||||
= UET_ReadOnly UE_RO
|
||||
|
|
@ -725,14 +728,13 @@ rebalanceTotalEntrySet
|
|||
UpdateEntrySet
|
||||
{ utFrom0 = (f0, f0links)
|
||||
, utTo0
|
||||
, -- , utPairs
|
||||
utFromUnk
|
||||
, utFromUnk
|
||||
, utToUnk
|
||||
, utFromRO
|
||||
, utToRO
|
||||
, utCurrency
|
||||
, -- , utToUnkLink0
|
||||
utTotalValue
|
||||
, utTotalValue
|
||||
, utBudget
|
||||
} =
|
||||
do
|
||||
(f0val, (tpairs, fs)) <-
|
||||
|
|
@ -782,10 +784,10 @@ rebalanceTotalEntrySet
|
|||
updateFixed :: UpdateEntry i StaticValue -> State EntryBals Rational
|
||||
updateFixed e = do
|
||||
let v = unStaticValue $ ueValue e
|
||||
modify $ mapAdd_ (ueAcnt e, utCurrency) v
|
||||
modify $ mapAdd_ (ueAcnt e, utCurrency, utBudget) v
|
||||
return v
|
||||
updateUnknown e = do
|
||||
let key = (ueAcnt e, utCurrency)
|
||||
let key = (ueAcnt e, utCurrency, utBudget)
|
||||
curBal <- gets (M.findWithDefault 0 key)
|
||||
let v = case ueValue e of
|
||||
EVPercent p -> p * curBal
|
||||
|
|
@ -799,13 +801,12 @@ rebalanceFullEntrySet
|
|||
UpdateEntrySet
|
||||
{ utFrom0
|
||||
, utTo0
|
||||
, -- , utPairs
|
||||
utFromUnk
|
||||
, utFromUnk
|
||||
, utToUnk
|
||||
, utFromRO
|
||||
, utToRO
|
||||
, utCurrency
|
||||
-- , utToUnkLink0
|
||||
, utBudget
|
||||
} =
|
||||
do
|
||||
let (f_ro, f_lnkd) = case utFrom0 of
|
||||
|
|
@ -857,10 +858,10 @@ rebalanceFullEntrySet
|
|||
updateFixed :: UpdateEntry i StaticValue -> State EntryBals Rational
|
||||
updateFixed e = do
|
||||
let v = unStaticValue $ ueValue e
|
||||
modify $ mapAdd_ (ueAcnt e, utCurrency) v
|
||||
modify $ mapAdd_ (ueAcnt e, utCurrency, utBudget) v
|
||||
return v
|
||||
updateUnknown e = do
|
||||
let key = (ueAcnt e, utCurrency)
|
||||
let key = (ueAcnt e, utCurrency, utBudget)
|
||||
curBal <- gets (M.findWithDefault 0 key)
|
||||
let v = case ueValue e of
|
||||
EVPercent p -> p * curBal
|
||||
|
|
@ -872,9 +873,11 @@ rebalanceFullEntrySet
|
|||
|
||||
balanceSecondaryEntrySet
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> SecondayEntrySet
|
||||
=> T.Text
|
||||
-> SecondayEntrySet
|
||||
-> StateT EntryBals m InsertEntrySet
|
||||
balanceSecondaryEntrySet
|
||||
budgetName
|
||||
EntrySet
|
||||
{ esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
|
||||
, esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
|
||||
|
|
@ -884,15 +887,15 @@ balanceSecondaryEntrySet
|
|||
fs' <- mapErrors resolveAcntAndTags (f0 :| fs)
|
||||
t0' <- resolveAcntAndTags t0
|
||||
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'
|
||||
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'
|
||||
-- TODO wet
|
||||
let (acntID, sign) = eAcnt t0'
|
||||
let t0Val = -(entrySum (NE.toList fs'') + entrySum ts'')
|
||||
modify (mapAdd_ (acntID, curID) t0Val)
|
||||
modify (mapAdd_ (acntID, curID, budgetName) t0Val)
|
||||
let t0'' =
|
||||
InsertEntry
|
||||
{ ieEntry = t0' {eValue = fromIntegral (sign2Int sign) * t0Val, eAcnt = acntID}
|
||||
|
|
@ -911,9 +914,11 @@ balanceSecondaryEntrySet
|
|||
|
||||
balancePrimaryEntrySet
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> PrimaryEntrySet
|
||||
=> T.Text
|
||||
-> PrimaryEntrySet
|
||||
-> StateT EntryBals m InsertEntrySet
|
||||
balancePrimaryEntrySet
|
||||
budgetName
|
||||
EntrySet
|
||||
{ esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
|
||||
, esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
|
||||
|
|
@ -927,13 +932,13 @@ balancePrimaryEntrySet
|
|||
let tsres = mapErrors resolveAcntAndTags ts
|
||||
combineErrorM (combineError f0res fsres (,)) (combineError t0res tsres (,)) $
|
||||
\(f0', fs') (t0', ts') -> do
|
||||
let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a) curID
|
||||
fs'' <- doEntries balFromEntry curID esTotalValue f0' fs'
|
||||
let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a budgetName) curID budgetName
|
||||
fs'' <- doEntries balFromEntry curID budgetName esTotalValue f0' fs'
|
||||
|
||||
let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs''
|
||||
|
||||
let balToEntry = balanceEntry (balanceLinked fv curID precision) curID
|
||||
ts'' <- doEntries balToEntry curID (-esTotalValue) t0' ts'
|
||||
let balToEntry = balanceEntry (balanceLinked fv curID budgetName precision) curID budgetName
|
||||
ts'' <- doEntries balToEntry curID budgetName (-esTotalValue) t0' ts'
|
||||
return $
|
||||
InsertEntrySet
|
||||
{ iesCurrency = curID
|
||||
|
|
@ -945,16 +950,17 @@ doEntries
|
|||
:: (MonadInsertError m)
|
||||
=> (Entry (AccountRId, AcntSign) v TagRId -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId))
|
||||
-> CurrencyRId
|
||||
-> T.Text
|
||||
-> Rational
|
||||
-> Entry (AccountRId, AcntSign) () TagRId
|
||||
-> [Entry (AccountRId, AcntSign) v 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
|
||||
let e0val = tot - entrySum es'
|
||||
-- TODO not dry
|
||||
let s = fromIntegral $ sign2Int sign -- NOTE hack
|
||||
modify (mapAdd_ (acntID, curID) e0val)
|
||||
modify (mapAdd_ (acntID, curID, budgetName) e0val)
|
||||
let e' =
|
||||
InsertEntry
|
||||
{ ieEntry = e {eValue = s * e0val, eAcnt = acntID}
|
||||
|
|
@ -971,11 +977,12 @@ balanceLinked
|
|||
:: MonadInsertError m
|
||||
=> Vector Rational
|
||||
-> CurrencyRId
|
||||
-> T.Text
|
||||
-> Natural
|
||||
-> AccountRId
|
||||
-> LinkDeferred Rational
|
||||
-> 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
|
||||
let res = fmap (go lngScale) $ from V.!? fromIntegral lngIndex
|
||||
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
|
||||
-- file from which it came
|
||||
Nothing -> throwError undefined
|
||||
(LinkDeferred d) -> liftInnerS $ balanceDeferred curID acntID d
|
||||
(LinkDeferred d) -> liftInnerS $ balanceDeferred curID acntID budgetName d
|
||||
where
|
||||
go s = negate . roundPrecision precision . (* s) . fromRational
|
||||
|
||||
balanceDeferred
|
||||
:: CurrencyRId
|
||||
-> AccountRId
|
||||
-> T.Text
|
||||
-> EntryValue Rational
|
||||
-> State EntryBals (Rational, Maybe DBDeferred)
|
||||
balanceDeferred curID acntID (EntryValue t v) = do
|
||||
newval <- findBalance acntID curID t v
|
||||
balanceDeferred curID acntID budgetName (EntryValue t v) = do
|
||||
newval <- findBalance acntID curID budgetName t v
|
||||
let d = case t of
|
||||
TFixed -> Nothing
|
||||
TBalance -> Just $ EntryBalance v
|
||||
|
|
@ -1004,12 +1012,13 @@ balanceEntry
|
|||
:: (MonadInsertError m)
|
||||
=> (AccountRId -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
|
||||
-> CurrencyRId
|
||||
-> T.Text
|
||||
-> Entry (AccountRId, AcntSign) v 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
|
||||
(newVal, deferred) <- f acntID eValue
|
||||
modify (mapAdd_ (acntID, curID) newVal)
|
||||
modify (mapAdd_ (acntID, curID, budgetName) newVal)
|
||||
return $
|
||||
InsertEntry
|
||||
{ ieEntry = e {eValue = s * newVal, eAcnt = acntID}
|
||||
|
|
@ -1029,11 +1038,12 @@ resolveAcntAndTags e@Entry {eAcnt, eTags} = do
|
|||
findBalance
|
||||
:: AccountRId
|
||||
-> CurrencyRId
|
||||
-> T.Text
|
||||
-> TransferType
|
||||
-> Rational
|
||||
-> State EntryBals Rational
|
||||
findBalance acnt cur t v = do
|
||||
curBal <- gets (M.findWithDefault 0 (acnt, cur))
|
||||
findBalance acnt cur name t v = do
|
||||
curBal <- gets (M.findWithDefault 0 (acnt, cur, name))
|
||||
return $ case t of
|
||||
TBalance -> v - curBal
|
||||
TPercent -> v * curBal
|
||||
|
|
@ -1041,19 +1051,21 @@ findBalance acnt cur t v = do
|
|||
|
||||
expandTransfers
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> TxCommit
|
||||
=> CommitR
|
||||
-> T.Text
|
||||
-> DaySpan
|
||||
-> [PairedTransfer]
|
||||
-> m [Tx TxCommit]
|
||||
expandTransfers tc bounds = fmap concat . mapErrors (expandTransfer tc bounds)
|
||||
-> m [Tx CommitR]
|
||||
expandTransfers tc name bounds = fmap concat . mapErrors (expandTransfer tc name bounds)
|
||||
|
||||
expandTransfer
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> TxCommit
|
||||
=> CommitR
|
||||
-> T.Text
|
||||
-> DaySpan
|
||||
-> PairedTransfer
|
||||
-> m [Tx TxCommit]
|
||||
expandTransfer tc bounds Transfer {transAmounts, transTo, transCurrency, transFrom} = do
|
||||
-> m [Tx CommitR]
|
||||
expandTransfer tc name bounds Transfer {transAmounts, transTo, transCurrency, transFrom} = do
|
||||
txs <- mapErrors go transAmounts
|
||||
return $ concat txs
|
||||
where
|
||||
|
|
@ -1072,6 +1084,7 @@ expandTransfer tc bounds Transfer {transAmounts, transTo, transCurrency, transFr
|
|||
, txPrimary = Right p
|
||||
, txOther = []
|
||||
, txDescr = desc
|
||||
, txBudget = name
|
||||
}
|
||||
|
||||
entryPair
|
||||
|
|
|
|||
Loading…
Reference in New Issue