ENH clean up (and hopefully fix) lots of balancing stuff
This commit is contained in:
parent
d9709f565f
commit
dce3ff4166
|
|
@ -422,21 +422,6 @@ whenHash_ t o f = do
|
|||
hs <- askDBState kmNewCommits
|
||||
if h `elem` hs then Just . (c,) <$> f else return Nothing
|
||||
|
||||
-- resolveEntry :: (MonadInsertError m, MonadFinance m) => BalEntry -> m KeyEntry
|
||||
-- resolveEntry s@InsertEntry {feEntry = e@Entry {eValue, eTags, eAcnt}, feCurrency} = do
|
||||
-- let aRes = lookupAccountKey eAcnt
|
||||
-- let cRes = lookupCurrencyKey feCurrency
|
||||
-- let sRes = lookupAccountSign eAcnt
|
||||
-- let tagRes = combineErrors $ fmap lookupTag eTags
|
||||
-- -- TODO correct sign here?
|
||||
-- -- TODO lenses would be nice here
|
||||
-- combineError (combineError3 aRes cRes sRes (,,)) tagRes $
|
||||
-- \(aid, cid, sign) tags ->
|
||||
-- s
|
||||
-- { feCurrency = cid
|
||||
-- , feEntry = e {eAcnt = aid, eValue = fromIntegral (sign2Int sign) * eValue, eTags = tags}
|
||||
-- }
|
||||
|
||||
readUpdates
|
||||
:: (MonadInsertError m, MonadSqlQuery m)
|
||||
=> [Int]
|
||||
|
|
@ -584,24 +569,41 @@ splitTo from0 fromUnk (t0 :| ts) = do
|
|||
primary = uncurry makeUnkUE t0
|
||||
splitLinked t@(_, e) = maybe (Left t) (Right . (,t)) $ entryRCachedLink e
|
||||
|
||||
-- ASSUME from and toLinked are sorted according to index and 'fst' respectively
|
||||
-- | Match linked credit entries with unknown entries, returning a list of
|
||||
-- matches and non-matching (read-only) credit entries. ASSUME both lists are
|
||||
-- sorted according to index and 'fst' respectively. NOTE the output will NOT be
|
||||
-- sorted.
|
||||
zipPaired
|
||||
:: [UEUnk]
|
||||
-> [(Int, NonEmpty (EntryRId, EntryR))]
|
||||
-> InsertExcept ([(UEUnk, [UELink])], [UE_RO])
|
||||
zipPaired = go ([], [])
|
||||
where
|
||||
go (facc, tacc) (f : fs) ((ti, tls) : ts)
|
||||
| ueIndex f == ti = do
|
||||
tls' <- mapErrors makeLinkUnk tls
|
||||
go ((f, NE.toList tls') : facc, tacc) fs ts
|
||||
| otherwise = go ((f, []) : facc, tacc ++ toRO tls) fs ts
|
||||
go (facc, tacc) fs ts =
|
||||
return
|
||||
( reverse facc ++ ((,[]) <$> fs)
|
||||
, tacc ++ concatMap (toRO . snd) ts
|
||||
)
|
||||
toRO = NE.toList . fmap (makeRoUE . snd)
|
||||
nolinks = ((,[]) <$>)
|
||||
go acc fs [] = return $ first (nolinks fs ++) acc
|
||||
go (facc, tacc) fs ((ti, tls) : ts) = do
|
||||
let (lesser, rest) = L.span ((< ti) . ueIndex) fs
|
||||
links <- NE.toList <$> mapErrors makeLinkUnk tls
|
||||
let (nextLink, fs') = case rest of
|
||||
(r0 : rs)
|
||||
| ueIndex r0 == ti -> (Just (r0, links), rs)
|
||||
| otherwise -> (Nothing, rest)
|
||||
_ -> (Nothing, rest)
|
||||
let acc' = (nolinks lesser ++ facc, tacc)
|
||||
let ros = NE.toList $ makeRoUE . snd <$> tls
|
||||
let f = maybe (second (++ ros)) (\u -> first (u :)) nextLink
|
||||
go (f acc') fs' ts
|
||||
|
||||
-- go (facc, tacc) (f : fs) ((ti, tls) : ts)
|
||||
-- | ueIndex f == ti = do
|
||||
-- tls' <- mapErrors makeLinkUnk tls
|
||||
-- go ((f, NE.toList tls') : facc, tacc) fs ts
|
||||
-- | otherwise = go ((f, []) : facc, tacc ++ toRO tls) fs ts
|
||||
-- go (facc, tacc) fs ts =
|
||||
-- return
|
||||
-- ( reverse facc ++ ((,[]) <$> fs)
|
||||
-- , tacc ++ concatMap (toRO . snd) ts
|
||||
-- )
|
||||
|
||||
makeLinkUnk :: (EntryRId, EntryR) -> InsertExcept UELink
|
||||
makeLinkUnk (k, e) =
|
||||
|
|
|
|||
|
|
@ -60,6 +60,7 @@ data DBUpdates = DBUpdates
|
|||
, duNewAcntIds :: ![Entity AccountR]
|
||||
, duNewCurrencyIds :: ![Entity CurrencyR]
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
type CurrencyM = Reader CurrencyMap
|
||||
|
||||
|
|
@ -135,10 +136,6 @@ data EntryBin
|
|||
| ToRead ReadEntry
|
||||
| ToInsert (Tx CommitR)
|
||||
|
||||
type KeyEntry = InsertEntry AccountRId CurrencyRId TagRId
|
||||
|
||||
type BalEntry = InsertEntry AcntID CurID TagID
|
||||
|
||||
type TreeR = Tree ([T.Text], AccountRId)
|
||||
|
||||
type MonadFinance = MonadReader DBState
|
||||
|
|
@ -255,15 +252,15 @@ data Tx k = Tx
|
|||
}
|
||||
deriving (Generic, Show)
|
||||
|
||||
data InsertEntry a c t = InsertEntry
|
||||
data InsertEntry = InsertEntry
|
||||
{ ieDeferred :: !(Maybe DBDeferred)
|
||||
, ieEntry :: !(Entry a Rational t)
|
||||
, ieEntry :: !(Entry AccountRId Rational TagRId)
|
||||
}
|
||||
|
||||
data InsertEntrySet = InsertEntrySet
|
||||
{ iesCurrency :: !CurrencyRId
|
||||
, iesFromEntries :: !(NonEmpty (InsertEntry AccountRId CurrencyRId TagRId))
|
||||
, iesToEntries :: !(NonEmpty (InsertEntry AccountRId CurrencyRId TagRId))
|
||||
, iesFromEntries :: !(NonEmpty InsertEntry)
|
||||
, iesToEntries :: !(NonEmpty InsertEntry)
|
||||
}
|
||||
|
||||
data InsertTx = InsertTx
|
||||
|
|
@ -290,8 +287,6 @@ data LinkDeferred a
|
|||
|
||||
-- type RawFromEntry = Entry AcntID (Deferred Rational) CurID TagID
|
||||
|
||||
-- type BalEntry = InsertEntry AcntID CurID TagID
|
||||
|
||||
data MatchRes a = MatchPass !a | MatchFail | MatchSkip
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -677,7 +677,6 @@ 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]
|
||||
|
|
@ -691,7 +690,7 @@ balanceTxs ebs =
|
|||
liftInnerS $
|
||||
either rebalanceTotalEntrySet rebalanceFullEntrySet utx
|
||||
go (ToRead ReadEntry {reCurrency, reAcnt, reValue, reBudget}) = do
|
||||
modify $ mapAdd_ (reAcnt, reCurrency, reBudget) reValue
|
||||
modify $ mapAdd_ (reAcnt, (reCurrency, reBudget)) reValue
|
||||
return Nothing
|
||||
go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate, txBudget}) = do
|
||||
e <- either (balancePrimaryEntrySet txBudget) (balanceSecondaryEntrySet txBudget) txPrimary
|
||||
|
|
@ -715,18 +714,20 @@ binDate (ToUpdate (Left UpdateEntrySet {utDate})) = utDate
|
|||
binDate (ToRead ReadEntry {reDate}) = reDate
|
||||
binDate (ToInsert Tx {txDate}) = txDate
|
||||
|
||||
type EntryBals = M.Map (AccountRId, CurrencyRId, Text) Rational
|
||||
type BCKey = (CurrencyRId, Text)
|
||||
|
||||
data UpdateEntryType a b
|
||||
= UET_ReadOnly UE_RO
|
||||
| UET_Unk a
|
||||
| UET_Linked b
|
||||
type ABCKey = (AccountRId, BCKey)
|
||||
|
||||
type EntryBals = M.Map ABCKey Rational
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- rebalancing
|
||||
|
||||
-- TODO make sure new values are rounded properly here
|
||||
rebalanceTotalEntrySet :: TotalUpdateEntrySet -> State EntryBals [UEBalanced]
|
||||
rebalanceTotalEntrySet
|
||||
UpdateEntrySet
|
||||
{ utFrom0 = (f0, f0links)
|
||||
{ utFrom0 = (f0@UpdateEntry {ueAcnt = f0Acnt}, f0links)
|
||||
, utTo0
|
||||
, utFromUnk
|
||||
, utToUnk
|
||||
|
|
@ -737,64 +738,14 @@ rebalanceTotalEntrySet
|
|||
, utBudget
|
||||
} =
|
||||
do
|
||||
(f0val, (tpairs, fs)) <-
|
||||
fmap (second partitionEithers) $
|
||||
foldM goFrom (utTotalValue, []) $
|
||||
L.sortOn idx $
|
||||
(UET_ReadOnly <$> utFromRO)
|
||||
++ (UET_Linked <$> utFromUnk)
|
||||
let f0' = f0 {ueValue = StaticValue f0val}
|
||||
let tsLink0 = fmap (unlink (-f0val)) f0links
|
||||
(t0val, tsUnk) <-
|
||||
fmap (second catMaybes) $
|
||||
foldM goTo (-utTotalValue, []) $
|
||||
L.sortOn idx2 $
|
||||
(UET_Linked <$> (tpairs ++ tsLink0))
|
||||
++ (UET_Unk <$> utToUnk)
|
||||
++ (UET_ReadOnly <$> utToRO)
|
||||
let t0 = utTo0 {ueValue = StaticValue t0val}
|
||||
return (f0' : fs ++ (t0 : tsUnk))
|
||||
(fval, fs, tpairs) <- rebalanceDebit bc utFromRO utFromUnk
|
||||
let f0val = utTotalValue - fval
|
||||
modify $ mapAdd_ (f0Acnt, bc) f0val
|
||||
let tsLinked = tpairs ++ (unlink f0val <$> f0links)
|
||||
ts <- rebalanceCredit bc utTotalValue utTo0 utToUnk utToRO tsLinked
|
||||
return (f0 {ueValue = StaticValue f0val} : fs ++ ts)
|
||||
where
|
||||
project f _ _ (UET_ReadOnly e) = f e
|
||||
project _ f _ (UET_Unk e) = f e
|
||||
project _ _ f (UET_Linked p) = f p
|
||||
idx = project ueIndex ueIndex (ueIndex . fst)
|
||||
idx2 = project ueIndex ueIndex ueIndex
|
||||
-- TODO the sum accumulator thing is kinda awkward
|
||||
goFrom (tot, es) (UET_ReadOnly e) = do
|
||||
v <- updateFixed e
|
||||
return (tot - v, es)
|
||||
goFrom (tot, esPrev) (UET_Unk e) = do
|
||||
v <- updateUnknown e
|
||||
return (tot - v, Right e {ueValue = StaticValue v} : esPrev)
|
||||
goFrom (tot, esPrev) (UET_Linked (e0, es)) = do
|
||||
v <- updateUnknown e0
|
||||
let e0' = Right $ e0 {ueValue = StaticValue v}
|
||||
let es' = fmap (Left . unlink (-v)) es
|
||||
return (tot - v, (e0' : es') ++ esPrev)
|
||||
goTo (tot, esPrev) (UET_ReadOnly e) = do
|
||||
v <- updateFixed e
|
||||
return (tot - v, esPrev)
|
||||
goTo (tot, esPrev) (UET_Linked e) = do
|
||||
v <- updateFixed e
|
||||
return (tot - v, Just e : esPrev)
|
||||
goTo (tot, esPrev) (UET_Unk e) = do
|
||||
v <- updateUnknown e
|
||||
return (tot - v, Just e {ueValue = StaticValue v} : esPrev)
|
||||
updateFixed :: UpdateEntry i StaticValue -> State EntryBals Rational
|
||||
updateFixed e = do
|
||||
let v = unStaticValue $ ueValue e
|
||||
modify $ mapAdd_ (ueAcnt e, utCurrency, utBudget) v
|
||||
return v
|
||||
updateUnknown e = do
|
||||
let key = (ueAcnt e, utCurrency, utBudget)
|
||||
curBal <- gets (M.findWithDefault 0 key)
|
||||
let v = case ueValue e of
|
||||
EVPercent p -> p * curBal
|
||||
EVBalance p -> p - curBal
|
||||
modify $ mapAdd_ key v
|
||||
return v
|
||||
unlink v e = e {ueValue = StaticValue $ v * unLinkScale (ueValue e)}
|
||||
bc = (utCurrency, utBudget)
|
||||
|
||||
rebalanceFullEntrySet :: FullUpdateEntrySet -> State EntryBals [UEBalanced]
|
||||
rebalanceFullEntrySet
|
||||
|
|
@ -809,108 +760,92 @@ rebalanceFullEntrySet
|
|||
, utBudget
|
||||
} =
|
||||
do
|
||||
let (f_ro, f_lnkd) = case utFrom0 of
|
||||
Left x -> (x : utFromRO, utFromUnk)
|
||||
Right x -> (utFromRO, x : utFromUnk)
|
||||
(tpairs, fs) <-
|
||||
fmap partitionEithers $
|
||||
foldM goFrom [] $
|
||||
L.sortOn idx $
|
||||
(UET_ReadOnly <$> f_ro)
|
||||
++ (UET_Linked <$> f_lnkd)
|
||||
tsUnk <-
|
||||
fmap catMaybes $
|
||||
foldM goTo [] $
|
||||
L.sortOn idx2 $
|
||||
(UET_Linked <$> tpairs)
|
||||
++ (UET_Unk <$> utToUnk)
|
||||
++ (UET_ReadOnly <$> utToRO)
|
||||
let t0val = -(entrySum fs + entrySum tsUnk)
|
||||
let t0 = utTo0 {ueValue = t0val}
|
||||
return (fs ++ (t0 : tsUnk))
|
||||
(ftot, fs, tpairs) <- rebalanceDebit bc rs ls
|
||||
ts <- rebalanceCredit bc ftot utTo0 utToUnk utToRO tpairs
|
||||
return (fs ++ ts)
|
||||
where
|
||||
project f _ _ (UET_ReadOnly e) = f e
|
||||
project _ f _ (UET_Unk e) = f e
|
||||
project _ _ f (UET_Linked p) = f p
|
||||
idx = project ueIndex ueIndex (ueIndex . fst)
|
||||
idx2 = project ueIndex ueIndex ueIndex
|
||||
-- TODO the sum accumulator thing is kinda awkward
|
||||
goFrom es (UET_ReadOnly e) = do
|
||||
_ <- updateFixed e
|
||||
return es
|
||||
goFrom esPrev (UET_Unk e) = do
|
||||
v <- updateUnknown e
|
||||
return $ Right e {ueValue = StaticValue v} : esPrev
|
||||
goFrom esPrev (UET_Linked (e0, es)) = do
|
||||
v <- updateUnknown e0
|
||||
let e0' = Right $ e0 {ueValue = StaticValue v}
|
||||
let es' = fmap (Left . unlink (-v)) es
|
||||
return $ (e0' : es') ++ esPrev
|
||||
goTo esPrev (UET_ReadOnly e) = do
|
||||
_ <- updateFixed e
|
||||
return esPrev
|
||||
goTo esPrev (UET_Linked e) = do
|
||||
_ <- updateFixed e
|
||||
return $ Just e : esPrev
|
||||
goTo esPrev (UET_Unk e) = do
|
||||
v <- updateUnknown e
|
||||
return $ Just e {ueValue = StaticValue v} : esPrev
|
||||
updateFixed :: UpdateEntry i StaticValue -> State EntryBals Rational
|
||||
updateFixed e = do
|
||||
let v = unStaticValue $ ueValue e
|
||||
modify $ mapAdd_ (ueAcnt e, utCurrency, utBudget) v
|
||||
return v
|
||||
updateUnknown e = do
|
||||
let key = (ueAcnt e, utCurrency, utBudget)
|
||||
curBal <- gets (M.findWithDefault 0 key)
|
||||
let v = case ueValue e of
|
||||
EVPercent p -> p * curBal
|
||||
EVBalance p -> p - curBal
|
||||
modify $ mapAdd_ key v
|
||||
return v
|
||||
unlink v e = e {ueValue = StaticValue $ v * unLinkScale (ueValue e)}
|
||||
entrySum = sum . fmap ueValue
|
||||
(rs, ls) = case utFrom0 of
|
||||
Left x -> (x : utFromRO, utFromUnk)
|
||||
Right x -> (utFromRO, x : utFromUnk)
|
||||
bc = (utCurrency, utBudget)
|
||||
|
||||
balanceSecondaryEntrySet
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> T.Text
|
||||
-> SecondayEntrySet
|
||||
-> StateT EntryBals m InsertEntrySet
|
||||
balanceSecondaryEntrySet
|
||||
budgetName
|
||||
EntrySet
|
||||
{ esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
|
||||
, esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
|
||||
, esCurrency = CurrencyPrec {cpID = curID, cpPrec = precision}
|
||||
} =
|
||||
do
|
||||
fs' <- mapErrors resolveAcntAndTags (f0 :| fs)
|
||||
t0' <- resolveAcntAndTags t0
|
||||
ts' <- mapErrors resolveAcntAndTags ts
|
||||
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 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, budgetName) t0Val)
|
||||
let t0'' =
|
||||
InsertEntry
|
||||
{ ieEntry = t0' {eValue = fromIntegral (sign2Int sign) * t0Val, eAcnt = acntID}
|
||||
, ieDeferred = Nothing
|
||||
}
|
||||
-- TODO don't record index here, just keep them in order and let the
|
||||
-- insertion function deal with assigning the index
|
||||
return $
|
||||
InsertEntrySet
|
||||
{ iesCurrency = curID
|
||||
, iesFromEntries = fs''
|
||||
, iesToEntries = t0'' :| ts''
|
||||
}
|
||||
where
|
||||
entrySum = sum . fmap (eValue . ieEntry)
|
||||
rebalanceDebit
|
||||
:: BCKey
|
||||
-> [UE_RO]
|
||||
-> [(UEUnk, [UELink])]
|
||||
-> State EntryBals (Rational, [UEBalanced], [UEBalanced])
|
||||
rebalanceDebit k ro linked = do
|
||||
(tot, (tpairs, fs)) <-
|
||||
fmap (second (partitionEithers . concat)) $
|
||||
sumM goFrom $
|
||||
L.sortOn idx $
|
||||
(Left <$> ro) ++ (Right <$> linked)
|
||||
return (tot, fs, tpairs)
|
||||
where
|
||||
idx = either ueIndex (ueIndex . fst)
|
||||
goFrom (Left e) = (,[]) <$> updateFixed k e
|
||||
goFrom (Right (e0, es)) = do
|
||||
v <- updateUnknown k e0
|
||||
let e0' = Right $ e0 {ueValue = StaticValue v}
|
||||
let es' = Left . unlink v <$> es
|
||||
return (v, e0' : es')
|
||||
|
||||
unlink :: Rational -> UELink -> UEBalanced
|
||||
unlink v e = e {ueValue = StaticValue $ (-v) * unLinkScale (ueValue e)}
|
||||
|
||||
rebalanceCredit
|
||||
:: BCKey
|
||||
-> Rational
|
||||
-> UEBlank
|
||||
-> [UEUnk]
|
||||
-> [UE_RO]
|
||||
-> [UEBalanced]
|
||||
-> State EntryBals [UEBalanced]
|
||||
rebalanceCredit k tot t0 us rs bs = do
|
||||
(tval, ts) <-
|
||||
fmap (second catMaybes) $
|
||||
sumM goTo $
|
||||
L.sortOn idx $
|
||||
(UETLinked <$> bs)
|
||||
++ (UETUnk <$> us)
|
||||
++ (UETReadOnly <$> rs)
|
||||
return (t0 {ueValue = StaticValue (-(tot + tval))} : ts)
|
||||
where
|
||||
idx = projectUET ueIndex ueIndex ueIndex
|
||||
goTo (UETReadOnly e) = (,Nothing) <$> updateFixed k e
|
||||
goTo (UETLinked e) = (,Just e) <$> updateFixed k e
|
||||
goTo (UETUnk e) = do
|
||||
v <- updateUnknown k e
|
||||
return (v, Just $ e {ueValue = StaticValue v})
|
||||
|
||||
data UpdateEntryType a b
|
||||
= UETReadOnly UE_RO
|
||||
| UETUnk a
|
||||
| UETLinked b
|
||||
|
||||
projectUET :: (UE_RO -> c) -> (a -> c) -> (b -> c) -> UpdateEntryType a b -> c
|
||||
projectUET f _ _ (UETReadOnly e) = f e
|
||||
projectUET _ f _ (UETUnk e) = f e
|
||||
projectUET _ _ f (UETLinked p) = f p
|
||||
|
||||
updateFixed :: BCKey -> UpdateEntry i StaticValue -> State EntryBals Rational
|
||||
updateFixed k e = do
|
||||
let v = unStaticValue $ ueValue e
|
||||
modify $ mapAdd_ (ueAcnt e, k) v
|
||||
return v
|
||||
|
||||
updateUnknown :: BCKey -> UpdateEntry i EntryValueUnk -> State EntryBals Rational
|
||||
updateUnknown k e = do
|
||||
let key = (ueAcnt e, k)
|
||||
curBal <- gets (M.findWithDefault 0 key)
|
||||
let v = case ueValue e of
|
||||
EVPercent p -> p * curBal
|
||||
EVBalance p -> p - curBal
|
||||
modify $ mapAdd_ key v
|
||||
return v
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- balancing
|
||||
|
||||
balancePrimaryEntrySet
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
|
|
@ -930,37 +865,72 @@ balancePrimaryEntrySet
|
|||
let t0res = resolveAcntAndTags t0
|
||||
let fsres = mapErrors resolveAcntAndTags fs
|
||||
let tsres = mapErrors resolveAcntAndTags ts
|
||||
let bc = (curID, budgetName)
|
||||
combineErrorM (combineError f0res fsres (,)) (combineError t0res tsres (,)) $
|
||||
\(f0', fs') (t0', ts') -> do
|
||||
let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a budgetName) curID budgetName
|
||||
fs'' <- doEntries balFromEntry curID budgetName esTotalValue f0' fs'
|
||||
let balFrom = fmap liftInnerS . balanceDeferred
|
||||
fs'' <- doEntries balFrom bc esTotalValue f0' fs'
|
||||
balanceFinal bc (-esTotalValue) precision fs'' t0' ts'
|
||||
|
||||
let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs''
|
||||
balanceSecondaryEntrySet
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> T.Text
|
||||
-> SecondayEntrySet
|
||||
-> StateT EntryBals m InsertEntrySet
|
||||
balanceSecondaryEntrySet
|
||||
budgetName
|
||||
EntrySet
|
||||
{ esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
|
||||
, esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
|
||||
, esCurrency = CurrencyPrec {cpID = curID, cpPrec = precision}
|
||||
} =
|
||||
do
|
||||
let fsRes = mapErrors resolveAcntAndTags (f0 :| fs)
|
||||
let t0Res = resolveAcntAndTags t0
|
||||
let tsRes = mapErrors resolveAcntAndTags ts
|
||||
combineErrorM fsRes (combineError t0Res tsRes (,)) $ \fs' (t0', ts') -> do
|
||||
fs'' <- mapErrors balFrom fs'
|
||||
let tot = entrySum (NE.toList fs'')
|
||||
balanceFinal bc (-tot) precision fs'' t0' ts'
|
||||
where
|
||||
entrySum = sum . fmap (eValue . ieEntry)
|
||||
balFrom = balanceEntry (fmap liftInnerS . balanceDeferred) bc
|
||||
bc = (curID, budgetName)
|
||||
|
||||
let balToEntry = balanceEntry (balanceLinked fv curID budgetName precision) curID budgetName
|
||||
ts'' <- doEntries balToEntry curID budgetName (-esTotalValue) t0' ts'
|
||||
return $
|
||||
InsertEntrySet
|
||||
{ iesCurrency = curID
|
||||
, iesFromEntries = fs''
|
||||
, iesToEntries = ts''
|
||||
}
|
||||
balanceFinal
|
||||
:: (MonadInsertError m)
|
||||
=> BCKey
|
||||
-> Rational
|
||||
-> Natural
|
||||
-> NonEmpty InsertEntry
|
||||
-> Entry (AccountRId, AcntSign) () TagRId
|
||||
-> [Entry (AccountRId, AcntSign) (LinkDeferred Rational) TagRId]
|
||||
-> StateT EntryBals m InsertEntrySet
|
||||
balanceFinal k@(curID, _) tot precision fs t0 ts = do
|
||||
let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs
|
||||
let balTo = balanceLinked fv precision
|
||||
ts' <- doEntries balTo k tot t0 ts
|
||||
return $
|
||||
InsertEntrySet
|
||||
{ iesCurrency = curID
|
||||
, iesFromEntries = fs
|
||||
, iesToEntries = ts'
|
||||
}
|
||||
|
||||
doEntries
|
||||
:: (MonadInsertError m)
|
||||
=> (Entry (AccountRId, AcntSign) v TagRId -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId))
|
||||
-> CurrencyRId
|
||||
-> T.Text
|
||||
=> (ABCKey -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
|
||||
-> BCKey
|
||||
-> Rational
|
||||
-> Entry (AccountRId, AcntSign) () TagRId
|
||||
-> [Entry (AccountRId, AcntSign) v TagRId]
|
||||
-> StateT EntryBals m (NonEmpty (InsertEntry AccountRId CurrencyRId TagRId))
|
||||
doEntries f curID budgetName tot e@Entry {eAcnt = (acntID, sign)} es = do
|
||||
es' <- mapErrors f es
|
||||
-> StateT EntryBals m (NonEmpty InsertEntry)
|
||||
doEntries f k tot e@Entry {eAcnt = (acntID, sign)} es = do
|
||||
es' <- mapErrors (balanceEntry f k) es
|
||||
let e0val = tot - entrySum es'
|
||||
-- TODO not dry
|
||||
let s = fromIntegral $ sign2Int sign -- NOTE hack
|
||||
modify (mapAdd_ (acntID, curID, budgetName) e0val)
|
||||
modify (mapAdd_ (acntID, k) e0val)
|
||||
let e' =
|
||||
InsertEntry
|
||||
{ ieEntry = e {eValue = s * e0val, eAcnt = acntID}
|
||||
|
|
@ -976,13 +946,11 @@ liftInnerS = mapStateT (return . runIdentity)
|
|||
balanceLinked
|
||||
:: MonadInsertError m
|
||||
=> Vector Rational
|
||||
-> CurrencyRId
|
||||
-> T.Text
|
||||
-> Natural
|
||||
-> AccountRId
|
||||
-> ABCKey
|
||||
-> LinkDeferred Rational
|
||||
-> StateT EntryBals m (Rational, Maybe DBDeferred)
|
||||
balanceLinked from curID budgetName precision acntID lg = case lg of
|
||||
balanceLinked from precision k lg = case lg of
|
||||
(LinkIndex LinkedNumGetter {lngIndex, lngScale}) -> do
|
||||
let res = fmap (go lngScale) $ from V.!? fromIntegral lngIndex
|
||||
case res of
|
||||
|
|
@ -990,18 +958,16 @@ balanceLinked from curID budgetName 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 budgetName d
|
||||
(LinkDeferred d) -> liftInnerS $ balanceDeferred k d
|
||||
where
|
||||
go s = negate . roundPrecision precision . (* s) . fromRational
|
||||
|
||||
balanceDeferred
|
||||
:: CurrencyRId
|
||||
-> AccountRId
|
||||
-> T.Text
|
||||
:: ABCKey
|
||||
-> EntryValue Rational
|
||||
-> State EntryBals (Rational, Maybe DBDeferred)
|
||||
balanceDeferred curID acntID budgetName (EntryValue t v) = do
|
||||
newval <- findBalance acntID curID budgetName t v
|
||||
balanceDeferred k (EntryValue t v) = do
|
||||
newval <- findBalance k t v
|
||||
let d = case t of
|
||||
TFixed -> Nothing
|
||||
TBalance -> Just $ EntryBalance v
|
||||
|
|
@ -1010,15 +976,14 @@ balanceDeferred curID acntID budgetName (EntryValue t v) = do
|
|||
|
||||
balanceEntry
|
||||
:: (MonadInsertError m)
|
||||
=> (AccountRId -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
|
||||
-> CurrencyRId
|
||||
-> T.Text
|
||||
=> (ABCKey -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
|
||||
-> BCKey
|
||||
-> Entry (AccountRId, AcntSign) v TagRId
|
||||
-> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId)
|
||||
balanceEntry f curID budgetName e@Entry {eValue, eAcnt = (acntID, sign)} = do
|
||||
-> StateT EntryBals m InsertEntry
|
||||
balanceEntry f k e@Entry {eValue, eAcnt = (acntID, sign)} = do
|
||||
let s = fromIntegral $ sign2Int sign
|
||||
(newVal, deferred) <- f acntID eValue
|
||||
modify (mapAdd_ (acntID, curID, budgetName) newVal)
|
||||
(newVal, deferred) <- f (acntID, k) eValue
|
||||
modify (mapAdd_ (acntID, k) newVal)
|
||||
return $
|
||||
InsertEntry
|
||||
{ ieEntry = e {eValue = s * newVal, eAcnt = acntID}
|
||||
|
|
@ -1036,19 +1001,20 @@ resolveAcntAndTags e@Entry {eAcnt, eTags} = do
|
|||
\(acntID, sign, _) tags -> e {eAcnt = (acntID, sign), eTags = tags}
|
||||
|
||||
findBalance
|
||||
:: AccountRId
|
||||
-> CurrencyRId
|
||||
-> T.Text
|
||||
:: ABCKey
|
||||
-> TransferType
|
||||
-> Rational
|
||||
-> State EntryBals Rational
|
||||
findBalance acnt cur name t v = do
|
||||
curBal <- gets (M.findWithDefault 0 (acnt, cur, name))
|
||||
findBalance k t v = do
|
||||
curBal <- gets (M.findWithDefault 0 k)
|
||||
return $ case t of
|
||||
TBalance -> v - curBal
|
||||
TPercent -> v * curBal
|
||||
TFixed -> v
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- transfers
|
||||
|
||||
expandTransfers
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> CommitR
|
||||
|
|
@ -1122,3 +1088,9 @@ withDates
|
|||
withDates bounds dp f = do
|
||||
days <- liftExcept $ expandDatePat bounds dp
|
||||
combineErrors $ fmap f days
|
||||
|
||||
sumM :: (Monad m, Num s) => (a -> m (s, b)) -> [a] -> m (s, [b])
|
||||
sumM f = mapAccumM (\s -> fmap (first (+ s)) . f) 0
|
||||
|
||||
mapAccumM :: (Monad m) => (s -> a -> m (s, b)) -> s -> [a] -> m (s, [b])
|
||||
mapAccumM f s = foldM (\(s', ys) -> fmap (second (: ys)) . f s') (s, [])
|
||||
|
|
|
|||
Loading…
Reference in New Issue