ADD calculations for running balances in statements
This commit is contained in:
parent
592c1550c0
commit
efffda378a
12
app/Main.hs
12
app/Main.hs
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue