From 5697a071ab074cd3f9e92203ba4c1b40d136013a Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Thu, 22 Jun 2023 23:27:14 -0400 Subject: [PATCH] WIP add lots of stuff to cache deferred calculations --- lib/Internal/Database.hs | 23 +++++-- lib/Internal/History.hs | 109 +++++++++++++++++++++++++++++---- lib/Internal/Types/Database.hs | 4 ++ lib/Internal/Types/Main.hs | 4 ++ lib/Internal/Utils.hs | 13 ++++ 5 files changed, 135 insertions(+), 18 deletions(-) diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs index 3c64fea..6457541 100644 --- a/lib/Internal/Database.hs +++ b/lib/Internal/Database.hs @@ -11,9 +11,7 @@ module Internal.Database , whenHash , whenHash_ , insertEntry - -- , insertEntrySet , resolveEntry - -- , resolveEntrySet ) where @@ -395,10 +393,23 @@ whenHash_ t o f = do if h `elem` hs then Just . (c,) <$> f else return Nothing insertEntry :: MonadSqlQuery m => TransactionRId -> KeyEntry -> m EntryRId -insertEntry t FullEntry {feEntry = Entry {eValue, eTags, eAcnt, eComment}, feCurrency} = do - k <- insert $ EntryR t feCurrency eAcnt eComment eValue - mapM_ (insert_ . TagRelationR k) eTags - return k +insertEntry + 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 + 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 s@FullEntry {feEntry = e@Entry {eValue, eTags, eAcnt}, feCurrency} = do diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs index e6a24ec..c53a02d 100644 --- a/lib/Internal/History.hs +++ b/lib/Internal/History.hs @@ -360,23 +360,49 @@ balanceEntrySet , esTotalValue } = do - let (lts, dts) = partitionEithers $ splitLinked <$> ts fs' <- doEntries fs esTotalValue f0 + -- let fs'' = fmap (\(i, e@Entry {eValue}) -> toFull) $ zip [0 ..] fs' let fv = V.fromList $ fmap eValue fs' + let (lts, dts) = partitionEithers $ splitLinked <$> ts lts' <- lift $ mapErrors (resolveLinked fv esCurrency day) lts ts' <- doEntries (dts ++ lts') (-esTotalValue) t0 - return $ toFull <$> fs' ++ ts' + -- let ts'' = fmap (uncurry toFull) $ zip [0 ..] ts' + return $ fs' -- ++ ts'' where 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 let val0 = tot - entrySum es' modify $ mapAdd_ (eAcnt e0, esCurrency) val0 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 LinkIndex l -> Left e {eValue = l} 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 :: (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 return $ e {eValue = Deferred False v'} -entrySum :: Num v => [Entry a v t] -> v -entrySum = sum . fmap eValue +unlinkGetter + :: (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 - :: CurID - -> Entry AcntID (Deferred Rational) TagID - -> State EntryBals (Entry AcntID Rational TagID) -balanceEntry curID e@Entry {eValue = Deferred toBal v, eAcnt} = do + :: (MonadInsertError m, MonadFinance m) + => (AcntID -> CurID -> v -> m (Rational, Maybe DBDeferred)) + -> CurID + -> 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) let newVal = if toBal then v - curBal else v modify (mapAdd_ key newVal) - return $ e {eValue = newVal} + return newVal where - key = (eAcnt, curID) + key = (acnt, cur) -- -- reimplementation from future version :/ -- mapAccumM diff --git a/lib/Internal/Types/Database.hs b/lib/Internal/Types/Database.hs index 6ea5506..8a73112 100644 --- a/lib/Internal/Types/Database.hs +++ b/lib/Internal/Types/Database.hs @@ -43,6 +43,7 @@ TransactionR sql=transactions commit CommitRId OnDeleteCascade date Day description T.Text + deferred Bool deriving Show Eq EntryR sql=entries transaction TransactionRId OnDeleteCascade @@ -50,6 +51,9 @@ EntryR sql=entries account AccountRId OnDeleteCascade memo T.Text value Rational + index Int + deferred_value (Maybe Rational) + deferred_link (Maybe Int) deriving Show Eq TagRelationR sql=tag_relations entry EntryRId OnDeleteCascade diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs index a5f520c..aeb8c3a 100644 --- a/lib/Internal/Types/Main.hs +++ b/lib/Internal/Types/Main.hs @@ -61,8 +61,12 @@ type CurrencyM = Reader CurrencyMap -- type DeferredKeyEntry = Entry AccountRId (Deferred Rational) CurrencyRId TagRId +data DBDeferred = EntryLinked Natural Rational | EntryBalance Rational + data FullEntry a c t = FullEntry { feCurrency :: !c + , feIndex :: !Int + , feDeferred :: !(Maybe DBDeferred) , feEntry :: !(Entry a Rational t) } diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index 0824b50..f52b76b 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -318,6 +318,7 @@ toTx } r@TxRecord {trAmount, trDate, trDesc} = do combineError curRes subRes $ \(cur, f, t, v) ss -> + -- TODO might be more efficient to set rebalance flag when balancing Tx { txDate = trDate , txDescr = trDesc @@ -343,6 +344,18 @@ toTx combineError3 fromRes toRes totRes (cur,,,) 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 :: TxRecord -> TxSubGetter