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
|
||||
runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
|
||||
let hTransRes = mapErrors insertHistTransfer hTs
|
||||
let bgtRes = mapErrors insertBudget $ budget config
|
||||
let runHist = do
|
||||
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
|
||||
res <- runExceptT $ do
|
||||
mapM_ (uncurry insertHistStmt) bSs
|
||||
combineError hTransRes bgtRes $ \_ _ -> ()
|
||||
rerunnableIO $ fromEither res
|
||||
res <- runExceptT $ combineError runHist runBudget $ \_ _ -> ()
|
||||
rerunnableIO $ fromEither res -- TODO why is this here?
|
||||
where
|
||||
root = takeDirectory c
|
||||
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 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
|
||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||
=> BalancedTransfer
|
||||
|
|
|
@ -1,8 +1,8 @@
|
|||
module Internal.History
|
||||
( splitHistory
|
||||
( readHistStmt
|
||||
, readHistTransfer
|
||||
, readHistStmt
|
||||
, insertHistory
|
||||
, splitHistory
|
||||
)
|
||||
where
|
||||
|
||||
|
@ -22,26 +22,16 @@ import qualified RIO.Text as T
|
|||
import RIO.Time
|
||||
import qualified RIO.Vector as V
|
||||
|
||||
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
|
||||
|
||||
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)
|
||||
-- readHistory
|
||||
-- :: (MonadInsertError m, MonadFinance m, MonadUnliftIO m)
|
||||
-- => FilePath
|
||||
-- -> [History]
|
||||
-- -> m [(CommitR, [RawTx])]
|
||||
-- readHistory root hs = do
|
||||
-- let (ts, ss) = splitHistory hs
|
||||
-- ts' <- catMaybes <$> mapErrorsIO readHistTransfer ts
|
||||
-- ss' <- catMaybes <$> mapErrorsIO (readHistStmt root) ss
|
||||
-- return $ ts' ++ ss'
|
||||
|
||||
readHistTransfer
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
|
@ -64,6 +54,11 @@ readHistTransfer
|
|||
return $ fmap tx days
|
||||
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
|
||||
:: (MonadUnliftIO m, MonadFinance m)
|
||||
=> FilePath
|
||||
|
@ -74,6 +69,22 @@ readHistStmt root i = whenHash_ CTImport i $ do
|
|||
bounds <- askDBState kmStatementInterval
|
||||
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
|
||||
|
||||
|
@ -325,16 +336,28 @@ balanceTxs ts = do
|
|||
(cs, ts') = L.unzip $ L.sortOn (txDate . snd) ts
|
||||
|
||||
balanceTxTargets
|
||||
:: M.Map a Rational
|
||||
:: (Ord a, Ord c)
|
||||
=> M.Map (a, c) Rational
|
||||
-> Tx (Entry a (Deferred Rational) c t)
|
||||
-> (M.Map a Rational, Tx (Entry a (Maybe Rational) c t))
|
||||
balanceTxTargets = undefined
|
||||
-> (M.Map (a, c) Rational, Tx (Entry a (Maybe Rational) c t))
|
||||
balanceTxTargets bals t@Tx {txEntries} = (bals', t {txEntries = es})
|
||||
where
|
||||
(bals', es) = L.mapAccumR balanceEntryTargets bals txEntries
|
||||
|
||||
balanceEntryTargets
|
||||
:: M.Map a Rational
|
||||
:: (Ord a, Ord c)
|
||||
=> M.Map (a, c) Rational
|
||||
-> Entry a (Deferred Rational) c t
|
||||
-> (M.Map a Rational, Entry a (Maybe Rational) c t)
|
||||
balanceEntryTargets = undefined
|
||||
-> (M.Map (a, c) Rational, Entry a (Maybe Rational) c t)
|
||||
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
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
|
|
|
@ -55,6 +55,7 @@ module Internal.Utils
|
|||
, lookupCurrencyKey
|
||||
, lookupCurrencyPrec
|
||||
, lookupTag
|
||||
, mapAdd_
|
||||
)
|
||||
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 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 f (a, b, c) = f a b c
|
||||
|
||||
|
|
Loading…
Reference in New Issue