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
|
hs <- askDBState kmNewCommits
|
||||||
if h `elem` hs then Just . (c,) <$> f else return Nothing
|
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
|
readUpdates
|
||||||
:: (MonadInsertError m, MonadSqlQuery m)
|
:: (MonadInsertError m, MonadSqlQuery m)
|
||||||
=> [Int]
|
=> [Int]
|
||||||
|
@ -584,24 +569,41 @@ splitTo from0 fromUnk (t0 :| ts) = do
|
||||||
primary = uncurry makeUnkUE t0
|
primary = uncurry makeUnkUE t0
|
||||||
splitLinked t@(_, e) = maybe (Left t) (Right . (,t)) $ entryRCachedLink e
|
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
|
zipPaired
|
||||||
:: [UEUnk]
|
:: [UEUnk]
|
||||||
-> [(Int, NonEmpty (EntryRId, EntryR))]
|
-> [(Int, NonEmpty (EntryRId, EntryR))]
|
||||||
-> InsertExcept ([(UEUnk, [UELink])], [UE_RO])
|
-> InsertExcept ([(UEUnk, [UELink])], [UE_RO])
|
||||||
zipPaired = go ([], [])
|
zipPaired = go ([], [])
|
||||||
where
|
where
|
||||||
go (facc, tacc) (f : fs) ((ti, tls) : ts)
|
nolinks = ((,[]) <$>)
|
||||||
| ueIndex f == ti = do
|
go acc fs [] = return $ first (nolinks fs ++) acc
|
||||||
tls' <- mapErrors makeLinkUnk tls
|
go (facc, tacc) fs ((ti, tls) : ts) = do
|
||||||
go ((f, NE.toList tls') : facc, tacc) fs ts
|
let (lesser, rest) = L.span ((< ti) . ueIndex) fs
|
||||||
| otherwise = go ((f, []) : facc, tacc ++ toRO tls) fs ts
|
links <- NE.toList <$> mapErrors makeLinkUnk tls
|
||||||
go (facc, tacc) fs ts =
|
let (nextLink, fs') = case rest of
|
||||||
return
|
(r0 : rs)
|
||||||
( reverse facc ++ ((,[]) <$> fs)
|
| ueIndex r0 == ti -> (Just (r0, links), rs)
|
||||||
, tacc ++ concatMap (toRO . snd) ts
|
| otherwise -> (Nothing, rest)
|
||||||
)
|
_ -> (Nothing, rest)
|
||||||
toRO = NE.toList . fmap (makeRoUE . snd)
|
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 :: (EntryRId, EntryR) -> InsertExcept UELink
|
||||||
makeLinkUnk (k, e) =
|
makeLinkUnk (k, e) =
|
||||||
|
|
|
@ -60,6 +60,7 @@ data DBUpdates = DBUpdates
|
||||||
, duNewAcntIds :: ![Entity AccountR]
|
, duNewAcntIds :: ![Entity AccountR]
|
||||||
, duNewCurrencyIds :: ![Entity CurrencyR]
|
, duNewCurrencyIds :: ![Entity CurrencyR]
|
||||||
}
|
}
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
type CurrencyM = Reader CurrencyMap
|
type CurrencyM = Reader CurrencyMap
|
||||||
|
|
||||||
|
@ -135,10 +136,6 @@ data EntryBin
|
||||||
| ToRead ReadEntry
|
| ToRead ReadEntry
|
||||||
| ToInsert (Tx CommitR)
|
| ToInsert (Tx CommitR)
|
||||||
|
|
||||||
type KeyEntry = InsertEntry AccountRId CurrencyRId TagRId
|
|
||||||
|
|
||||||
type BalEntry = InsertEntry AcntID CurID TagID
|
|
||||||
|
|
||||||
type TreeR = Tree ([T.Text], AccountRId)
|
type TreeR = Tree ([T.Text], AccountRId)
|
||||||
|
|
||||||
type MonadFinance = MonadReader DBState
|
type MonadFinance = MonadReader DBState
|
||||||
|
@ -255,15 +252,15 @@ data Tx k = Tx
|
||||||
}
|
}
|
||||||
deriving (Generic, Show)
|
deriving (Generic, Show)
|
||||||
|
|
||||||
data InsertEntry a c t = InsertEntry
|
data InsertEntry = InsertEntry
|
||||||
{ ieDeferred :: !(Maybe DBDeferred)
|
{ ieDeferred :: !(Maybe DBDeferred)
|
||||||
, ieEntry :: !(Entry a Rational t)
|
, ieEntry :: !(Entry AccountRId Rational TagRId)
|
||||||
}
|
}
|
||||||
|
|
||||||
data InsertEntrySet = InsertEntrySet
|
data InsertEntrySet = InsertEntrySet
|
||||||
{ iesCurrency :: !CurrencyRId
|
{ iesCurrency :: !CurrencyRId
|
||||||
, iesFromEntries :: !(NonEmpty (InsertEntry AccountRId CurrencyRId TagRId))
|
, iesFromEntries :: !(NonEmpty InsertEntry)
|
||||||
, iesToEntries :: !(NonEmpty (InsertEntry AccountRId CurrencyRId TagRId))
|
, iesToEntries :: !(NonEmpty InsertEntry)
|
||||||
}
|
}
|
||||||
|
|
||||||
data InsertTx = InsertTx
|
data InsertTx = InsertTx
|
||||||
|
@ -290,8 +287,6 @@ data LinkDeferred a
|
||||||
|
|
||||||
-- type RawFromEntry = Entry AcntID (Deferred Rational) CurID TagID
|
-- type RawFromEntry = Entry AcntID (Deferred Rational) CurID TagID
|
||||||
|
|
||||||
-- type BalEntry = InsertEntry AcntID CurID TagID
|
|
||||||
|
|
||||||
data MatchRes a = MatchPass !a | MatchFail | MatchSkip
|
data MatchRes a = MatchPass !a | MatchFail | MatchSkip
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
|
@ -677,7 +677,6 @@ 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]
|
||||||
|
@ -691,7 +690,7 @@ balanceTxs ebs =
|
||||||
liftInnerS $
|
liftInnerS $
|
||||||
either rebalanceTotalEntrySet rebalanceFullEntrySet utx
|
either rebalanceTotalEntrySet rebalanceFullEntrySet utx
|
||||||
go (ToRead ReadEntry {reCurrency, reAcnt, reValue, reBudget}) = do
|
go (ToRead ReadEntry {reCurrency, reAcnt, reValue, reBudget}) = do
|
||||||
modify $ mapAdd_ (reAcnt, reCurrency, reBudget) reValue
|
modify $ mapAdd_ (reAcnt, (reCurrency, reBudget)) reValue
|
||||||
return Nothing
|
return Nothing
|
||||||
go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate, txBudget}) = do
|
go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate, txBudget}) = do
|
||||||
e <- either (balancePrimaryEntrySet txBudget) (balanceSecondaryEntrySet txBudget) txPrimary
|
e <- either (balancePrimaryEntrySet txBudget) (balanceSecondaryEntrySet txBudget) txPrimary
|
||||||
|
@ -715,18 +714,20 @@ 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, Text) Rational
|
type BCKey = (CurrencyRId, Text)
|
||||||
|
|
||||||
data UpdateEntryType a b
|
type ABCKey = (AccountRId, BCKey)
|
||||||
= UET_ReadOnly UE_RO
|
|
||||||
| UET_Unk a
|
type EntryBals = M.Map ABCKey Rational
|
||||||
| UET_Linked b
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- rebalancing
|
||||||
|
|
||||||
-- TODO make sure new values are rounded properly here
|
-- TODO make sure new values are rounded properly here
|
||||||
rebalanceTotalEntrySet :: TotalUpdateEntrySet -> State EntryBals [UEBalanced]
|
rebalanceTotalEntrySet :: TotalUpdateEntrySet -> State EntryBals [UEBalanced]
|
||||||
rebalanceTotalEntrySet
|
rebalanceTotalEntrySet
|
||||||
UpdateEntrySet
|
UpdateEntrySet
|
||||||
{ utFrom0 = (f0, f0links)
|
{ utFrom0 = (f0@UpdateEntry {ueAcnt = f0Acnt}, f0links)
|
||||||
, utTo0
|
, utTo0
|
||||||
, utFromUnk
|
, utFromUnk
|
||||||
, utToUnk
|
, utToUnk
|
||||||
|
@ -737,64 +738,14 @@ rebalanceTotalEntrySet
|
||||||
, utBudget
|
, utBudget
|
||||||
} =
|
} =
|
||||||
do
|
do
|
||||||
(f0val, (tpairs, fs)) <-
|
(fval, fs, tpairs) <- rebalanceDebit bc utFromRO utFromUnk
|
||||||
fmap (second partitionEithers) $
|
let f0val = utTotalValue - fval
|
||||||
foldM goFrom (utTotalValue, []) $
|
modify $ mapAdd_ (f0Acnt, bc) f0val
|
||||||
L.sortOn idx $
|
let tsLinked = tpairs ++ (unlink f0val <$> f0links)
|
||||||
(UET_ReadOnly <$> utFromRO)
|
ts <- rebalanceCredit bc utTotalValue utTo0 utToUnk utToRO tsLinked
|
||||||
++ (UET_Linked <$> utFromUnk)
|
return (f0 {ueValue = StaticValue f0val} : fs ++ ts)
|
||||||
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))
|
|
||||||
where
|
where
|
||||||
project f _ _ (UET_ReadOnly e) = f e
|
bc = (utCurrency, utBudget)
|
||||||
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)}
|
|
||||||
|
|
||||||
rebalanceFullEntrySet :: FullUpdateEntrySet -> State EntryBals [UEBalanced]
|
rebalanceFullEntrySet :: FullUpdateEntrySet -> State EntryBals [UEBalanced]
|
||||||
rebalanceFullEntrySet
|
rebalanceFullEntrySet
|
||||||
|
@ -809,108 +760,92 @@ rebalanceFullEntrySet
|
||||||
, utBudget
|
, utBudget
|
||||||
} =
|
} =
|
||||||
do
|
do
|
||||||
let (f_ro, f_lnkd) = case utFrom0 of
|
(ftot, fs, tpairs) <- rebalanceDebit bc rs ls
|
||||||
Left x -> (x : utFromRO, utFromUnk)
|
ts <- rebalanceCredit bc ftot utTo0 utToUnk utToRO tpairs
|
||||||
Right x -> (utFromRO, x : utFromUnk)
|
return (fs ++ ts)
|
||||||
(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))
|
|
||||||
where
|
where
|
||||||
project f _ _ (UET_ReadOnly e) = f e
|
(rs, ls) = case utFrom0 of
|
||||||
project _ f _ (UET_Unk e) = f e
|
Left x -> (x : utFromRO, utFromUnk)
|
||||||
project _ _ f (UET_Linked p) = f p
|
Right x -> (utFromRO, x : utFromUnk)
|
||||||
idx = project ueIndex ueIndex (ueIndex . fst)
|
bc = (utCurrency, utBudget)
|
||||||
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
|
|
||||||
|
|
||||||
balanceSecondaryEntrySet
|
rebalanceDebit
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
:: BCKey
|
||||||
=> T.Text
|
-> [UE_RO]
|
||||||
-> SecondayEntrySet
|
-> [(UEUnk, [UELink])]
|
||||||
-> StateT EntryBals m InsertEntrySet
|
-> State EntryBals (Rational, [UEBalanced], [UEBalanced])
|
||||||
balanceSecondaryEntrySet
|
rebalanceDebit k ro linked = do
|
||||||
budgetName
|
(tot, (tpairs, fs)) <-
|
||||||
EntrySet
|
fmap (second (partitionEithers . concat)) $
|
||||||
{ esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
|
sumM goFrom $
|
||||||
, esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
|
L.sortOn idx $
|
||||||
, esCurrency = CurrencyPrec {cpID = curID, cpPrec = precision}
|
(Left <$> ro) ++ (Right <$> linked)
|
||||||
} =
|
return (tot, fs, tpairs)
|
||||||
do
|
where
|
||||||
fs' <- mapErrors resolveAcntAndTags (f0 :| fs)
|
idx = either ueIndex (ueIndex . fst)
|
||||||
t0' <- resolveAcntAndTags t0
|
goFrom (Left e) = (,[]) <$> updateFixed k e
|
||||||
ts' <- mapErrors resolveAcntAndTags ts
|
goFrom (Right (e0, es)) = do
|
||||||
let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a budgetName) curID budgetName
|
v <- updateUnknown k e0
|
||||||
fs'' <- mapErrors balFromEntry fs'
|
let e0' = Right $ e0 {ueValue = StaticValue v}
|
||||||
let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs''
|
let es' = Left . unlink v <$> es
|
||||||
let balToEntry = balanceEntry (balanceLinked fv curID budgetName precision) curID budgetName
|
return (v, e0' : es')
|
||||||
ts'' <- mapErrors balToEntry ts'
|
|
||||||
-- TODO wet
|
unlink :: Rational -> UELink -> UEBalanced
|
||||||
let (acntID, sign) = eAcnt t0'
|
unlink v e = e {ueValue = StaticValue $ (-v) * unLinkScale (ueValue e)}
|
||||||
let t0Val = -(entrySum (NE.toList fs'') + entrySum ts'')
|
|
||||||
modify (mapAdd_ (acntID, curID, budgetName) t0Val)
|
rebalanceCredit
|
||||||
let t0'' =
|
:: BCKey
|
||||||
InsertEntry
|
-> Rational
|
||||||
{ ieEntry = t0' {eValue = fromIntegral (sign2Int sign) * t0Val, eAcnt = acntID}
|
-> UEBlank
|
||||||
, ieDeferred = Nothing
|
-> [UEUnk]
|
||||||
}
|
-> [UE_RO]
|
||||||
-- TODO don't record index here, just keep them in order and let the
|
-> [UEBalanced]
|
||||||
-- insertion function deal with assigning the index
|
-> State EntryBals [UEBalanced]
|
||||||
return $
|
rebalanceCredit k tot t0 us rs bs = do
|
||||||
InsertEntrySet
|
(tval, ts) <-
|
||||||
{ iesCurrency = curID
|
fmap (second catMaybes) $
|
||||||
, iesFromEntries = fs''
|
sumM goTo $
|
||||||
, iesToEntries = t0'' :| ts''
|
L.sortOn idx $
|
||||||
}
|
(UETLinked <$> bs)
|
||||||
where
|
++ (UETUnk <$> us)
|
||||||
entrySum = sum . fmap (eValue . ieEntry)
|
++ (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
|
balancePrimaryEntrySet
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
:: (MonadInsertError m, MonadFinance m)
|
||||||
|
@ -930,37 +865,72 @@ balancePrimaryEntrySet
|
||||||
let t0res = resolveAcntAndTags t0
|
let t0res = resolveAcntAndTags t0
|
||||||
let fsres = mapErrors resolveAcntAndTags fs
|
let fsres = mapErrors resolveAcntAndTags fs
|
||||||
let tsres = mapErrors resolveAcntAndTags ts
|
let tsres = mapErrors resolveAcntAndTags ts
|
||||||
|
let bc = (curID, budgetName)
|
||||||
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 budgetName) curID budgetName
|
let balFrom = fmap liftInnerS . balanceDeferred
|
||||||
fs'' <- doEntries balFromEntry curID budgetName esTotalValue f0' fs'
|
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
|
balanceFinal
|
||||||
ts'' <- doEntries balToEntry curID budgetName (-esTotalValue) t0' ts'
|
:: (MonadInsertError m)
|
||||||
return $
|
=> BCKey
|
||||||
InsertEntrySet
|
-> Rational
|
||||||
{ iesCurrency = curID
|
-> Natural
|
||||||
, iesFromEntries = fs''
|
-> NonEmpty InsertEntry
|
||||||
, iesToEntries = ts''
|
-> 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
|
doEntries
|
||||||
:: (MonadInsertError m)
|
:: (MonadInsertError m)
|
||||||
=> (Entry (AccountRId, AcntSign) v TagRId -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId))
|
=> (ABCKey -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
|
||||||
-> CurrencyRId
|
-> BCKey
|
||||||
-> 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)
|
||||||
doEntries f curID budgetName tot e@Entry {eAcnt = (acntID, sign)} es = do
|
doEntries f k tot e@Entry {eAcnt = (acntID, sign)} es = do
|
||||||
es' <- mapErrors f es
|
es' <- mapErrors (balanceEntry f k) 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, budgetName) e0val)
|
modify (mapAdd_ (acntID, k) e0val)
|
||||||
let e' =
|
let e' =
|
||||||
InsertEntry
|
InsertEntry
|
||||||
{ ieEntry = e {eValue = s * e0val, eAcnt = acntID}
|
{ ieEntry = e {eValue = s * e0val, eAcnt = acntID}
|
||||||
|
@ -976,13 +946,11 @@ liftInnerS = mapStateT (return . runIdentity)
|
||||||
balanceLinked
|
balanceLinked
|
||||||
:: MonadInsertError m
|
:: MonadInsertError m
|
||||||
=> Vector Rational
|
=> Vector Rational
|
||||||
-> CurrencyRId
|
|
||||||
-> T.Text
|
|
||||||
-> Natural
|
-> Natural
|
||||||
-> AccountRId
|
-> ABCKey
|
||||||
-> LinkDeferred Rational
|
-> LinkDeferred Rational
|
||||||
-> StateT EntryBals m (Rational, Maybe DBDeferred)
|
-> 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
|
(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
|
||||||
|
@ -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
|
-- 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 budgetName d
|
(LinkDeferred d) -> liftInnerS $ balanceDeferred k d
|
||||||
where
|
where
|
||||||
go s = negate . roundPrecision precision . (* s) . fromRational
|
go s = negate . roundPrecision precision . (* s) . fromRational
|
||||||
|
|
||||||
balanceDeferred
|
balanceDeferred
|
||||||
:: CurrencyRId
|
:: ABCKey
|
||||||
-> AccountRId
|
|
||||||
-> T.Text
|
|
||||||
-> EntryValue Rational
|
-> EntryValue Rational
|
||||||
-> State EntryBals (Rational, Maybe DBDeferred)
|
-> State EntryBals (Rational, Maybe DBDeferred)
|
||||||
balanceDeferred curID acntID budgetName (EntryValue t v) = do
|
balanceDeferred k (EntryValue t v) = do
|
||||||
newval <- findBalance acntID curID budgetName t v
|
newval <- findBalance k t v
|
||||||
let d = case t of
|
let d = case t of
|
||||||
TFixed -> Nothing
|
TFixed -> Nothing
|
||||||
TBalance -> Just $ EntryBalance v
|
TBalance -> Just $ EntryBalance v
|
||||||
|
@ -1010,15 +976,14 @@ balanceDeferred curID acntID budgetName (EntryValue t v) = do
|
||||||
|
|
||||||
balanceEntry
|
balanceEntry
|
||||||
:: (MonadInsertError m)
|
:: (MonadInsertError m)
|
||||||
=> (AccountRId -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
|
=> (ABCKey -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
|
||||||
-> CurrencyRId
|
-> BCKey
|
||||||
-> T.Text
|
|
||||||
-> Entry (AccountRId, AcntSign) v TagRId
|
-> Entry (AccountRId, AcntSign) v TagRId
|
||||||
-> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId)
|
-> StateT EntryBals m InsertEntry
|
||||||
balanceEntry f curID budgetName e@Entry {eValue, eAcnt = (acntID, sign)} = do
|
balanceEntry f k 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, k) eValue
|
||||||
modify (mapAdd_ (acntID, curID, budgetName) newVal)
|
modify (mapAdd_ (acntID, k) newVal)
|
||||||
return $
|
return $
|
||||||
InsertEntry
|
InsertEntry
|
||||||
{ ieEntry = e {eValue = s * newVal, eAcnt = acntID}
|
{ 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}
|
\(acntID, sign, _) tags -> e {eAcnt = (acntID, sign), eTags = tags}
|
||||||
|
|
||||||
findBalance
|
findBalance
|
||||||
:: AccountRId
|
:: ABCKey
|
||||||
-> CurrencyRId
|
|
||||||
-> T.Text
|
|
||||||
-> TransferType
|
-> TransferType
|
||||||
-> Rational
|
-> Rational
|
||||||
-> State EntryBals Rational
|
-> State EntryBals Rational
|
||||||
findBalance acnt cur name t v = do
|
findBalance k t v = do
|
||||||
curBal <- gets (M.findWithDefault 0 (acnt, cur, name))
|
curBal <- gets (M.findWithDefault 0 k)
|
||||||
return $ case t of
|
return $ case t of
|
||||||
TBalance -> v - curBal
|
TBalance -> v - curBal
|
||||||
TPercent -> v * curBal
|
TPercent -> v * curBal
|
||||||
TFixed -> v
|
TFixed -> v
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- transfers
|
||||||
|
|
||||||
expandTransfers
|
expandTransfers
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
:: (MonadInsertError m, MonadFinance m)
|
||||||
=> CommitR
|
=> CommitR
|
||||||
|
@ -1122,3 +1088,9 @@ withDates
|
||||||
withDates bounds dp f = do
|
withDates bounds dp f = do
|
||||||
days <- liftExcept $ expandDatePat bounds dp
|
days <- liftExcept $ expandDatePat bounds dp
|
||||||
combineErrors $ fmap f days
|
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