WIP add lots of stuff to cache deferred calculations

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

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

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

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)
   }
 

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