WIP add lots of stuff to cache deferred calculations
This commit is contained in:
parent
09e03ff675
commit
5697a071ab
|
@ -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
|
||||
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
|
||||
|
|
|
@ -360,24 +360,50 @@ 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}
|
||||
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)
|
||||
=> Vector Rational
|
||||
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
}
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue