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
|
||||||
, 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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in New Issue