WIP add lots of stuff to cache deferred calculations

This commit is contained in:
Nathan Dwarshuis 2023-06-22 23:27:14 -04:00
parent 09e03ff675
commit 5697a071ab
5 changed files with 135 additions and 18 deletions

View File

@ -11,9 +11,7 @@ module Internal.Database
, whenHash , whenHash
, whenHash_ , whenHash_
, insertEntry , insertEntry
-- , insertEntrySet
, resolveEntry , resolveEntry
-- , resolveEntrySet
) )
where where
@ -395,10 +393,23 @@ whenHash_ t o f = do
if h `elem` hs then Just . (c,) <$> f else return Nothing if h `elem` hs then Just . (c,) <$> f else return Nothing
insertEntry :: MonadSqlQuery m => TransactionRId -> KeyEntry -> m EntryRId insertEntry :: MonadSqlQuery m => TransactionRId -> KeyEntry -> m EntryRId
insertEntry t FullEntry {feEntry = Entry {eValue, eTags, eAcnt, eComment}, feCurrency} = do insertEntry
k <- insert $ EntryR t feCurrency eAcnt eComment eValue t
FullEntry
{ feEntry = Entry {eValue, eTags, eAcnt, eComment}
, feCurrency
, feIndex
, feDeferred
} =
do
k <- insert $ EntryR t feCurrency eAcnt eComment eValue feIndex defval deflink
mapM_ (insert_ . TagRelationR k) eTags mapM_ (insert_ . TagRelationR k) eTags
return k return k
where
(defval, deflink) = case feDeferred of
(Just (EntryLinked index scale)) -> (Just scale, Just $ fromIntegral index)
(Just (EntryBalance target)) -> (Just target, Nothing)
Nothing -> (Nothing, Nothing)
resolveEntry :: (MonadInsertError m, MonadFinance m) => BalEntry -> m KeyEntry resolveEntry :: (MonadInsertError m, MonadFinance m) => BalEntry -> m KeyEntry
resolveEntry s@FullEntry {feEntry = e@Entry {eValue, eTags, eAcnt}, feCurrency} = do resolveEntry s@FullEntry {feEntry = e@Entry {eValue, eTags, eAcnt}, feCurrency} = do

View File

@ -360,23 +360,49 @@ balanceEntrySet
, esTotalValue , esTotalValue
} = } =
do do
let (lts, dts) = partitionEithers $ splitLinked <$> ts
fs' <- doEntries fs esTotalValue f0 fs' <- doEntries fs esTotalValue f0
-- let fs'' = fmap (\(i, e@Entry {eValue}) -> toFull) $ zip [0 ..] fs'
let fv = V.fromList $ fmap eValue fs' let fv = V.fromList $ fmap eValue fs'
let (lts, dts) = partitionEithers $ splitLinked <$> ts
lts' <- lift $ mapErrors (resolveLinked fv esCurrency day) lts lts' <- lift $ mapErrors (resolveLinked fv esCurrency day) lts
ts' <- doEntries (dts ++ lts') (-esTotalValue) t0 ts' <- doEntries (dts ++ lts') (-esTotalValue) t0
return $ toFull <$> fs' ++ ts' -- let ts'' = fmap (uncurry toFull) $ zip [0 ..] ts'
return $ fs' -- ++ ts''
where where
doEntries es tot e0 = do doEntries es tot e0 = do
es' <- liftInnerS $ mapM (uncurry (balanceEntry esCurrency)) $ zip [1 ..] es
let val0 = tot - entrySum es'
modify $ mapAdd_ (eAcnt e0, esCurrency) val0
return $ e0 {eValue = val0} : es'
doEntriesTo es tot e0 = do
es' <- liftInnerS $ mapM (balanceEntry esCurrency) es es' <- liftInnerS $ mapM (balanceEntry esCurrency) es
let val0 = tot - entrySum es' let val0 = tot - entrySum es'
modify $ mapAdd_ (eAcnt e0, esCurrency) val0 modify $ mapAdd_ (eAcnt e0, esCurrency) val0
return $ e0 {eValue = val0} : es' return $ e0 {eValue = val0} : es'
toFull e = FullEntry {feEntry = e, feCurrency = esCurrency} toFullDebit i e target =
FullEntry
{ feEntry = e
, feCurrency = esCurrency
, feIndex = i
, feDeferred = EntryBalance target
}
splitLinked e@Entry {eValue} = case eValue of splitLinked e@Entry {eValue} = case eValue of
LinkIndex l -> Left e {eValue = l} LinkIndex l -> Left e {eValue = l}
LinkDeferred d -> Right e {eValue = d} LinkDeferred d -> Right e {eValue = d}
liftInnerS = mapStateT (return . runIdentity) entrySum = sum . fmap (eValue . feEntry)
liftInnerS = mapStateT (return . runIdentity)
resolveCreditEntry
:: (MonadInsertError m, MonadFinance m)
=> Vector Rational
-> CurID
-> Day
-> Int
-> Entry AcntID LinkedNumGetter TagID
-> m (FullEntry AcntID CurID TagID)
resolveCreditEntry from cur day index e@Entry {eValue} = do
undefined
resolveLinked resolveLinked
:: (MonadInsertError m, MonadFinance m) :: (MonadInsertError m, MonadFinance m)
@ -393,20 +419,79 @@ resolveLinked from cur day e@Entry {eValue = LinkedNumGetter {lngIndex, lngScale
v' <- liftExcept $ roundPrecisionCur cur curMap $ lngScale * fromRational v v' <- liftExcept $ roundPrecisionCur cur curMap $ lngScale * fromRational v
return $ e {eValue = Deferred False v'} return $ e {eValue = Deferred False v'}
entrySum :: Num v => [Entry a v t] -> v unlinkGetter
entrySum = sum . fmap eValue :: (MonadInsertError m, MonadFinance m)
=> Vector Rational
-> CurID
-> LinkedNumGetter
-> m (Maybe Rational)
unlinkGetter from cur LinkedNumGetter {lngIndex, lngScale} = do
curMap <- askDBState kmCurrency
maybe (return Nothing) (go curMap) $ from V.!? fromIntegral lngIndex
where
go m = fmap Just . liftExcept . roundPrecisionCur cur m . (* lngScale) . fromRational
balanceFromEntry
:: (MonadInsertError m, MonadFinance m)
=> CurID
-> Int
-> Entry AcntID v TagID
-> StateT EntryBals m (FullEntry AcntID CurID TagID)
balanceFromEntry = balanceEntry (\a c -> liftInnerS . balanceDeferrred a c)
balanceDeferrred
:: AcntID
-> CurID
-> Deferred Rational
-> State EntryBals (Rational, Maybe DBDeferred)
balanceDeferrred acntID curID (Deferred toBal v) = do
newval <- findBalance acntID curID toBal v
return $ (newval, if toBal then Just (EntryBalance v) else Nothing)
balanceToEntry
:: (MonadInsertError m, MonadFinance m)
=> Vector Rational
-> Day
-> CurID
-> Int
-> Entry AcntID v TagID
-> StateT EntryBals m (FullEntry AcntID CurID TagID)
balanceToEntry from day = balanceEntry go
where
go _ curID (LinkIndex g@LinkedNumGetter {lngIndex, lngScale}) = do
res <- unlinkGetter from curID g
case res of
Just v -> return $ (v, Just $ EntryLinked lngIndex lngScale)
Nothing -> throwError undefined
go acntID curID (LinkDeferred d) = balanceDeferrred acntID curID d
balanceEntry balanceEntry
:: CurID :: (MonadInsertError m, MonadFinance m)
-> Entry AcntID (Deferred Rational) TagID => (AcntID -> CurID -> v -> m (Rational, Maybe DBDeferred))
-> State EntryBals (Entry AcntID Rational TagID) -> CurID
balanceEntry curID e@Entry {eValue = Deferred toBal v, eAcnt} = do -> Int
-> Entry AcntID v TagID
-> StateT EntryBals m (FullEntry AcntID CurID TagID)
balanceEntry f curID index e@Entry {eValue, eAcnt} = do
(newVal, deferred) <- lift $ f eAcnt curID eValue
return $
FullEntry
{ feEntry = e {eValue = newVal}
, feCurrency = curID
, feDeferred = deferred
, feIndex = index
}
where
key = (eAcnt, curID)
findBalance :: AcntID -> CurID -> Bool -> Rational -> State EntryBals Rational
findBalance acnt cur toBal v = do
curBal <- gets (M.findWithDefault 0 key) curBal <- gets (M.findWithDefault 0 key)
let newVal = if toBal then v - curBal else v let newVal = if toBal then v - curBal else v
modify (mapAdd_ key newVal) modify (mapAdd_ key newVal)
return $ e {eValue = newVal} return newVal
where where
key = (eAcnt, curID) key = (acnt, cur)
-- -- reimplementation from future version :/ -- -- reimplementation from future version :/
-- mapAccumM -- mapAccumM

View File

@ -43,6 +43,7 @@ TransactionR sql=transactions
commit CommitRId OnDeleteCascade commit CommitRId OnDeleteCascade
date Day date Day
description T.Text description T.Text
deferred Bool
deriving Show Eq deriving Show Eq
EntryR sql=entries EntryR sql=entries
transaction TransactionRId OnDeleteCascade transaction TransactionRId OnDeleteCascade
@ -50,6 +51,9 @@ EntryR sql=entries
account AccountRId OnDeleteCascade account AccountRId OnDeleteCascade
memo T.Text memo T.Text
value Rational value Rational
index Int
deferred_value (Maybe Rational)
deferred_link (Maybe Int)
deriving Show Eq deriving Show Eq
TagRelationR sql=tag_relations TagRelationR sql=tag_relations
entry EntryRId OnDeleteCascade entry EntryRId OnDeleteCascade

View File

@ -61,8 +61,12 @@ type CurrencyM = Reader CurrencyMap
-- type DeferredKeyEntry = Entry AccountRId (Deferred Rational) CurrencyRId TagRId -- type DeferredKeyEntry = Entry AccountRId (Deferred Rational) CurrencyRId TagRId
data DBDeferred = EntryLinked Natural Rational | EntryBalance Rational
data FullEntry a c t = FullEntry data FullEntry a c t = FullEntry
{ feCurrency :: !c { feCurrency :: !c
, feIndex :: !Int
, feDeferred :: !(Maybe DBDeferred)
, feEntry :: !(Entry a Rational t) , feEntry :: !(Entry a Rational t)
} }

View File

@ -318,6 +318,7 @@ toTx
} }
r@TxRecord {trAmount, trDate, trDesc} = do r@TxRecord {trAmount, trDate, trDesc} = do
combineError curRes subRes $ \(cur, f, t, v) ss -> combineError curRes subRes $ \(cur, f, t, v) ss ->
-- TODO might be more efficient to set rebalance flag when balancing
Tx Tx
{ txDate = trDate { txDate = trDate
, txDescr = trDesc , txDescr = trDesc
@ -343,6 +344,18 @@ toTx
combineError3 fromRes toRes totRes (cur,,,) combineError3 fromRes toRes totRes (cur,,,)
subRes = mapErrors (resolveSubGetter r) tgOtherEntries subRes = mapErrors (resolveSubGetter r) tgOtherEntries
-- anyDeferred :: DeferredEntrySet -> Bool
-- anyDeferred
-- EntrySet
-- { esFrom = HalfEntrySet {hesOther = fs}
-- , esTo = HalfEntrySet {hesOther = ts}
-- } =
-- any checkFrom fs || any checkTo ts
-- where
-- checkFrom Entry {eValue = (Deferred True _)} = True
-- checkFrom _ = False
-- checkTo = undefined
resolveSubGetter resolveSubGetter
:: TxRecord :: TxRecord
-> TxSubGetter -> TxSubGetter