ADD calculations for running balances in statements

This commit is contained in:
Nathan Dwarshuis 2023-06-13 20:12:29 -04:00
parent 592c1550c0
commit efffda378a
4 changed files with 61 additions and 38 deletions

View File

@ -180,13 +180,13 @@ runSync c = do
-- update the DB -- update the DB
runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
let hTransRes = mapErrors insertHistTransfer hTs let runHist = do
let bgtRes = mapErrors insertBudget $ budget config ts <- catMaybes <$> mapErrors readHistTransfer hTs
insertHistory $ bSs ++ ts
let runBudget = mapErrors insertBudget $ budget config
updateDBState updates -- TODO this will only work if foreign keys are deferred updateDBState updates -- TODO this will only work if foreign keys are deferred
res <- runExceptT $ do res <- runExceptT $ combineError runHist runBudget $ \_ _ -> ()
mapM_ (uncurry insertHistStmt) bSs rerunnableIO $ fromEither res -- TODO why is this here?
combineError hTransRes bgtRes $ \_ _ -> ()
rerunnableIO $ fromEither res
where where
root = takeDirectory c root = takeDirectory c
err (InsertException es) = do err (InsertException es) = do

View File

@ -74,10 +74,6 @@ balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen
amtToMove bal BTPercent x = -(x / 100 * bal) amtToMove bal BTPercent x = -(x / 100 * bal)
amtToMove bal BTTarget x = x - bal amtToMove bal BTTarget x = x - bal
-- TODO this seems too general for this module
mapAdd_ :: (Ord k, Num v) => k -> v -> M.Map k v -> M.Map k v
mapAdd_ k v = M.alter (maybe (Just v) (Just . (+ v))) k
insertBudgetTx insertBudgetTx
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> BalancedTransfer => BalancedTransfer

View File

@ -1,8 +1,8 @@
module Internal.History module Internal.History
( splitHistory ( readHistStmt
, readHistTransfer , readHistTransfer
, readHistStmt
, insertHistory , insertHistory
, splitHistory
) )
where where
@ -22,26 +22,16 @@ import qualified RIO.Text as T
import RIO.Time import RIO.Time
import qualified RIO.Vector as V import qualified RIO.Vector as V
splitHistory :: [History] -> ([HistTransfer], [Statement]) -- readHistory
splitHistory = partitionEithers . fmap go -- :: (MonadInsertError m, MonadFinance m, MonadUnliftIO m)
where -- => FilePath
go (HistTransfer x) = Left x -- -> [History]
go (HistStatement x) = Right x -- -> m [(CommitR, [RawTx])]
-- readHistory root hs = do
insertHistory -- let (ts, ss) = splitHistory hs
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) -- ts' <- catMaybes <$> mapErrorsIO readHistTransfer ts
=> [(CommitR, [RawTx])] -- ss' <- catMaybes <$> mapErrorsIO (readHistStmt root) ss
-> m () -- return $ ts' ++ ss'
insertHistory hs = do
bs <- balanceTxs $ concatMap (\(c, xs) -> fmap (c,) xs) hs
forM_ (groupKey (\(CommitR h _) -> h) bs) $ \(c, ts) -> do
ck <- insert c
mapM_ (insertTx ck) ts
groupKey :: Ord c => (a -> c) -> [(a, b)] -> [(a, [b])]
groupKey f = fmap go . NE.groupAllWith (f . fst)
where
go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
readHistTransfer readHistTransfer
:: (MonadInsertError m, MonadFinance m) :: (MonadInsertError m, MonadFinance m)
@ -64,6 +54,11 @@ readHistTransfer
return $ fmap tx days return $ fmap tx days
concat <$> mapErrors go amts concat <$> mapErrors go amts
groupKey :: Ord c => (a -> c) -> [(a, b)] -> [(a, [b])]
groupKey f = fmap go . NE.groupAllWith (f . fst)
where
go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
readHistStmt readHistStmt
:: (MonadUnliftIO m, MonadFinance m) :: (MonadUnliftIO m, MonadFinance m)
=> FilePath => FilePath
@ -74,6 +69,22 @@ readHistStmt root i = whenHash_ CTImport i $ do
bounds <- askDBState kmStatementInterval bounds <- askDBState kmStatementInterval
return $ filter (inDaySpan bounds . txDate) bs return $ filter (inDaySpan bounds . txDate) bs
splitHistory :: [History] -> ([HistTransfer], [Statement])
splitHistory = partitionEithers . fmap go
where
go (HistTransfer x) = Left x
go (HistStatement x) = Right x
insertHistory
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> [(CommitR, [RawTx])]
-> m ()
insertHistory hs = do
bs <- balanceTxs $ concatMap (\(c, xs) -> fmap (c,) xs) hs
forM_ (groupKey (\(CommitR h _) -> h) bs) $ \(c, ts) -> do
ck <- insert c
mapM_ (insertTx ck) ts
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- low-level transaction stuff -- low-level transaction stuff
@ -325,16 +336,28 @@ balanceTxs ts = do
(cs, ts') = L.unzip $ L.sortOn (txDate . snd) ts (cs, ts') = L.unzip $ L.sortOn (txDate . snd) ts
balanceTxTargets balanceTxTargets
:: M.Map a Rational :: (Ord a, Ord c)
=> M.Map (a, c) Rational
-> Tx (Entry a (Deferred Rational) c t) -> Tx (Entry a (Deferred Rational) c t)
-> (M.Map a Rational, Tx (Entry a (Maybe Rational) c t)) -> (M.Map (a, c) Rational, Tx (Entry a (Maybe Rational) c t))
balanceTxTargets = undefined balanceTxTargets bals t@Tx {txEntries} = (bals', t {txEntries = es})
where
(bals', es) = L.mapAccumR balanceEntryTargets bals txEntries
balanceEntryTargets balanceEntryTargets
:: M.Map a Rational :: (Ord a, Ord c)
=> M.Map (a, c) Rational
-> Entry a (Deferred Rational) c t -> Entry a (Deferred Rational) c t
-> (M.Map a Rational, Entry a (Maybe Rational) c t) -> (M.Map (a, c) Rational, Entry a (Maybe Rational) c t)
balanceEntryTargets = undefined balanceEntryTargets bals e@Entry {eValue, eAcnt, eCurrency} = (bals', e {eValue = v})
where
key = (eAcnt, eCurrency)
curBal = M.findWithDefault 0 key bals
v = case eValue of
ConstD x -> Just x
Target x -> Just $ x - curBal
Derive -> Nothing
bals' = maybe bals (\y -> mapAdd_ key y bals) v
balanceTx balanceTx
:: (MonadInsertError m, MonadFinance m) :: (MonadInsertError m, MonadFinance m)

View File

@ -55,6 +55,7 @@ module Internal.Utils
, lookupCurrencyKey , lookupCurrencyKey
, lookupCurrencyPrec , lookupCurrencyPrec
, lookupTag , lookupTag
, mapAdd_
) )
where where
@ -855,6 +856,9 @@ unlessLefts_ e f = unlessLefts e (\x -> void (f x) >> return mzero)
-- thrice :: (a -> d) -> (b -> e) -> (c -> f) -> (a, b, c) -> (d, e, f) -- thrice :: (a -> d) -> (b -> e) -> (c -> f) -> (a, b, c) -> (d, e, f)
-- thrice f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) -- thrice f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
mapAdd_ :: (Ord k, Num v) => k -> v -> M.Map k v -> M.Map k v
mapAdd_ k v = M.alter (maybe (Just v) (Just . (+ v))) k
uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 f (a, b, c) = f a b c uncurry3 f (a, b, c) = f a b c