WIP balance all transactions in budget
This commit is contained in:
parent
e6a39cb5ea
commit
7f2a87670c
|
@ -107,22 +107,12 @@ withDates dp f = do
|
||||||
|
|
||||||
insertBudget :: MonadFinance m => Budget -> SqlPersistT m [InsertError]
|
insertBudget :: MonadFinance m => Budget -> SqlPersistT m [InsertError]
|
||||||
insertBudget Budget {budgetLabel = name, income = is, transfers = es} = do
|
insertBudget Budget {budgetLabel = name, income = is, transfers = es} = do
|
||||||
es1 <- mapM (insertIncome name) is
|
res1 <- mapM (insertIncome name) is
|
||||||
es2 <- insertTransfers name es
|
res2 <- expandTransfers name es
|
||||||
return $ concat es1 ++ es2
|
unlessLefts (concatEithers2 (fmap concat $ concatEithersL res1) res2 (++)) $
|
||||||
|
\txs -> do
|
||||||
-- TODO this hashes twice (not that it really matters)
|
let bals = balanceTransfers txs
|
||||||
whenHash
|
concat <$> mapM insertBudgetTx bals
|
||||||
:: (Hashable a, MonadFinance m)
|
|
||||||
=> ConfigType
|
|
||||||
-> a
|
|
||||||
-> b
|
|
||||||
-> (Key CommitR -> SqlPersistT m b)
|
|
||||||
-> SqlPersistT m b
|
|
||||||
whenHash t o def f = do
|
|
||||||
let h = hash o
|
|
||||||
hs <- lift $ askDBState kmNewCommits
|
|
||||||
if h `elem` hs then f =<< insert (CommitR h t) else return def
|
|
||||||
|
|
||||||
-- TODO allow currency conversions here
|
-- TODO allow currency conversions here
|
||||||
data BudgetSplit b = BudgetSplit
|
data BudgetSplit b = BudgetSplit
|
||||||
|
@ -145,55 +135,67 @@ data BudgetTx = BudgetTx
|
||||||
, btDesc :: !T.Text
|
, btDesc :: !T.Text
|
||||||
}
|
}
|
||||||
|
|
||||||
insertIncome :: MonadFinance m => T.Text -> Income -> SqlPersistT m [InsertError]
|
data TransferTx = TransferTx
|
||||||
|
{ trxMeta :: !BudgetMeta
|
||||||
|
, trxFrom :: !(BudgetSplit IncomeBucket)
|
||||||
|
, trxTo :: !(BudgetSplit ExpenseBucket)
|
||||||
|
, trxValue :: !Rational
|
||||||
|
, trxType :: AmountType
|
||||||
|
, trxDesc :: !T.Text
|
||||||
|
}
|
||||||
|
|
||||||
|
insertIncome :: MonadFinance m => T.Text -> Income -> SqlPersistT m (EitherErrs [TransferTx])
|
||||||
insertIncome
|
insertIncome
|
||||||
name
|
name
|
||||||
i@Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal} =
|
i@Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal} =
|
||||||
whenHash CTIncome i [] $ \c ->
|
whenHash CTIncome i (Right []) $ \c -> case (balanceIncome i) of
|
||||||
unlessLeft (balanceIncome i) $ \balance -> do
|
Left e -> return $ Left [e]
|
||||||
res <- withDates incWhen $ \day -> do
|
Right balance ->
|
||||||
|
fmap (fmap concat) $ withDates incWhen $ \day -> do
|
||||||
let meta = BudgetMeta c day incCurrency name
|
let meta = BudgetMeta c day incCurrency name
|
||||||
let fromAllos b = concatMap (fromAllo meta incFrom (Just b))
|
let fromAllos b = concatMap (fromAllo meta incFrom (Just b))
|
||||||
let pre = fromAllos PreTax incPretax
|
let pre = fromAllos PreTax incPretax
|
||||||
let tax = fmap (fromTax meta incFrom) incTaxes
|
let tax = fmap (fromTax meta incFrom) incTaxes
|
||||||
let post = fromAllos PostTax incPosttax
|
let post = fromAllos PostTax incPosttax
|
||||||
let bal =
|
let bal =
|
||||||
BudgetTx
|
TransferTx
|
||||||
{ btMeta = meta
|
{ trxMeta = meta
|
||||||
, btFrom = BudgetSplit incFrom $ Just PostTax
|
, trxFrom = BudgetSplit incFrom $ Just PostTax
|
||||||
, btTo = BudgetSplit incToBal Nothing
|
, trxTo = BudgetSplit incToBal Nothing
|
||||||
, btValue = balance
|
, trxValue = balance
|
||||||
, btDesc = "balance after deductions"
|
, trxType = FixedAmt
|
||||||
|
, trxDesc = "balance after deductions"
|
||||||
}
|
}
|
||||||
fmap concat $ mapM insertBudgetTx $ bal : (pre ++ tax ++ post)
|
return $ bal : (pre ++ tax ++ post)
|
||||||
unlessLefts res $ return . concat
|
|
||||||
|
|
||||||
fromAllo
|
fromAllo
|
||||||
:: BudgetMeta
|
:: BudgetMeta
|
||||||
-> AcntID
|
-> AcntID
|
||||||
-> Maybe IncomeBucket
|
-> Maybe IncomeBucket
|
||||||
-> Allocation
|
-> Allocation
|
||||||
-> [BudgetTx]
|
-> [TransferTx]
|
||||||
fromAllo meta from ib Allocation {alloPath, alloAmts, alloBucket} =
|
fromAllo meta from ib Allocation {alloPath, alloAmts, alloBucket} =
|
||||||
fmap (toBT alloPath) alloAmts
|
fmap (toBT alloPath) alloAmts
|
||||||
where
|
where
|
||||||
toBT to (Amount desc v) =
|
toBT to (Amount desc v) =
|
||||||
BudgetTx
|
TransferTx
|
||||||
{ btFrom = BudgetSplit from ib
|
{ trxFrom = BudgetSplit from ib
|
||||||
, btTo = BudgetSplit to $ Just alloBucket
|
, trxTo = BudgetSplit to $ Just alloBucket
|
||||||
, btValue = dec2Rat v
|
, trxValue = dec2Rat v
|
||||||
, btDesc = desc
|
, trxDesc = desc
|
||||||
, btMeta = meta
|
, trxType = FixedAmt
|
||||||
|
, trxMeta = meta
|
||||||
}
|
}
|
||||||
|
|
||||||
fromTax :: BudgetMeta -> AcntID -> Tax -> BudgetTx
|
fromTax :: BudgetMeta -> AcntID -> Tax -> TransferTx
|
||||||
fromTax meta from Tax {taxAcnt = to, taxValue = v} =
|
fromTax meta from Tax {taxAcnt = to, taxValue = v} =
|
||||||
BudgetTx
|
TransferTx
|
||||||
{ btFrom = BudgetSplit from (Just IntraTax)
|
{ trxFrom = BudgetSplit from (Just IntraTax)
|
||||||
, btTo = BudgetSplit to (Just Fixed)
|
, trxTo = BudgetSplit to (Just Fixed)
|
||||||
, btValue = dec2Rat v
|
, trxValue = dec2Rat v
|
||||||
, btDesc = ""
|
, trxDesc = ""
|
||||||
, btMeta = meta
|
, trxType = FixedAmt
|
||||||
|
, trxMeta = meta
|
||||||
}
|
}
|
||||||
|
|
||||||
balanceIncome :: Income -> EitherErr Rational
|
balanceIncome :: Income -> EitherErr Rational
|
||||||
|
@ -216,12 +218,6 @@ sumAllocation = sum . fmap (dec2Rat . amtValue) . alloAmts
|
||||||
sumTaxes :: [Tax] -> Rational
|
sumTaxes :: [Tax] -> Rational
|
||||||
sumTaxes = sum . fmap (dec2Rat . taxValue)
|
sumTaxes = sum . fmap (dec2Rat . taxValue)
|
||||||
|
|
||||||
insertTransfers :: MonadFinance m => T.Text -> [Transfer] -> SqlPersistT m [InsertError]
|
|
||||||
insertTransfers name ts = do
|
|
||||||
res <- expandTransfers name ts
|
|
||||||
unlessLefts res $ \txs ->
|
|
||||||
fmap concat <$> mapM insertBudgetTx $ balanceTransfers txs
|
|
||||||
|
|
||||||
expandTransfers :: MonadFinance m => T.Text -> [Transfer] -> SqlPersistT m (EitherErrs [TransferTx])
|
expandTransfers :: MonadFinance m => T.Text -> [Transfer] -> SqlPersistT m (EitherErrs [TransferTx])
|
||||||
expandTransfers name ts = do
|
expandTransfers name ts = do
|
||||||
txs <- mapM (expandTransfer name) ts
|
txs <- mapM (expandTransfer name) ts
|
||||||
|
@ -231,21 +227,27 @@ expandTransfers name ts = do
|
||||||
balanceTransfers :: [TransferTx] -> [BudgetTx]
|
balanceTransfers :: [TransferTx] -> [BudgetTx]
|
||||||
balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (bmWhen . trxMeta) ts
|
balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (bmWhen . trxMeta) ts
|
||||||
where
|
where
|
||||||
initBals = M.fromList $ fmap (,0) $ L.nub $ (fmap trxTo ts ++ fmap trxTo ts)
|
initBals =
|
||||||
|
M.fromList $
|
||||||
|
fmap (,0) $
|
||||||
|
L.nub $
|
||||||
|
(fmap (bsAcnt . trxTo) ts ++ fmap (bsAcnt . trxTo) ts)
|
||||||
updateBal x = M.update (Just . (+ x))
|
updateBal x = M.update (Just . (+ x))
|
||||||
lookupBal = M.findWithDefault (error "this should not happen")
|
lookupBal = M.findWithDefault (error "this should not happen")
|
||||||
go bals TransferTx {trxMeta, trxFrom, trxTo, trxValue, trxType, trxDesc} =
|
go bals TransferTx {trxMeta, trxFrom, trxTo, trxValue, trxType, trxDesc} =
|
||||||
let bal = lookupBal trxTo bals
|
let from = bsAcnt trxFrom
|
||||||
|
to = bsAcnt trxTo
|
||||||
|
bal = lookupBal to bals
|
||||||
x = amtToMove bal trxType trxValue
|
x = amtToMove bal trxType trxValue
|
||||||
t =
|
t =
|
||||||
BudgetTx
|
BudgetTx
|
||||||
{ btMeta = trxMeta
|
{ btMeta = trxMeta
|
||||||
, btFrom = BudgetSplit trxFrom Nothing
|
, btFrom = trxFrom
|
||||||
, btTo = BudgetSplit trxTo Nothing
|
, btTo = trxTo
|
||||||
, btValue = x
|
, btValue = x
|
||||||
, btDesc = trxDesc
|
, btDesc = trxDesc
|
||||||
}
|
}
|
||||||
in (updateBal x trxFrom $ updateBal (-x) trxFrom bals, t)
|
in (updateBal x to $ updateBal (-x) from bals, t)
|
||||||
-- TODO might need to query signs to make this intuitive; as it is this will
|
-- TODO might need to query signs to make this intuitive; as it is this will
|
||||||
-- probably work, but for credit accounts I might need to supply a negative
|
-- probably work, but for credit accounts I might need to supply a negative
|
||||||
-- target value
|
-- target value
|
||||||
|
@ -268,42 +270,14 @@ expandTransfer name t@Transfer {transAmounts, transTo, transCurrency, transFrom}
|
||||||
in return $
|
in return $
|
||||||
TransferTx
|
TransferTx
|
||||||
{ trxMeta = meta
|
{ trxMeta = meta
|
||||||
, trxFrom = transFrom
|
, trxFrom = BudgetSplit transFrom Nothing
|
||||||
, trxTo = transTo
|
, trxTo = BudgetSplit transTo Nothing
|
||||||
, trxValue = dec2Rat v
|
, trxValue = dec2Rat v
|
||||||
, trxType = atype
|
, trxType = atype
|
||||||
, trxDesc = desc
|
, trxDesc = desc
|
||||||
}
|
}
|
||||||
return $ concat <$> concatEithersL res
|
return $ concat <$> concatEithersL res
|
||||||
|
|
||||||
data TransferTx = TransferTx
|
|
||||||
{ trxMeta :: !BudgetMeta
|
|
||||||
, trxFrom :: !AcntID
|
|
||||||
, trxTo :: !AcntID
|
|
||||||
, trxValue :: !Rational
|
|
||||||
, trxType :: AmountType
|
|
||||||
, trxDesc :: !T.Text
|
|
||||||
}
|
|
||||||
|
|
||||||
-- amountBalance
|
|
||||||
-- :: (MonadFinance m, MonadBalance m)
|
|
||||||
-- => AmountType
|
|
||||||
-- -> AcntID
|
|
||||||
-- -> Rational
|
|
||||||
-- -> SqlPersistT m (EitherErr Rational)
|
|
||||||
-- amountBalance at i v = do
|
|
||||||
-- res <- lookupAccountKey i
|
|
||||||
-- case res of
|
|
||||||
-- Left e -> return $ Left e
|
|
||||||
-- Right k -> do
|
|
||||||
-- b <- lookupBalance k
|
|
||||||
-- return $ Right $ case at of
|
|
||||||
-- FixedAmt -> v
|
|
||||||
-- -- TODO what is the sign for this?
|
|
||||||
-- Percent -> v / 100 * b
|
|
||||||
-- -- TODO what is the sign for this?
|
|
||||||
-- Target -> b - v
|
|
||||||
|
|
||||||
insertBudgetTx :: MonadFinance m => BudgetTx -> SqlPersistT m [InsertError]
|
insertBudgetTx :: MonadFinance m => BudgetTx -> SqlPersistT m [InsertError]
|
||||||
insertBudgetTx BudgetTx {btFrom, btTo, btMeta, btValue, btDesc} = do
|
insertBudgetTx BudgetTx {btFrom, btTo, btMeta, btValue, btDesc} = do
|
||||||
res <- splitPair (bsAcnt btFrom) (bsAcnt btTo) (bmCur btMeta) btValue
|
res <- splitPair (bsAcnt btFrom) (bsAcnt btTo) (bmCur btMeta) btValue
|
||||||
|
@ -457,3 +431,16 @@ lookupAccountSign = fmap (fmap snd) . lookupAccount
|
||||||
|
|
||||||
lookupCurrency :: MonadFinance m => T.Text -> SqlPersistT m (EitherErr (Key CurrencyR))
|
lookupCurrency :: MonadFinance m => T.Text -> SqlPersistT m (EitherErr (Key CurrencyR))
|
||||||
lookupCurrency c = lookupErr (DBKey CurField) c <$> lift (askDBState kmCurrency)
|
lookupCurrency c = lookupErr (DBKey CurField) c <$> lift (askDBState kmCurrency)
|
||||||
|
|
||||||
|
-- TODO this hashes twice (not that it really matters)
|
||||||
|
whenHash
|
||||||
|
:: (Hashable a, MonadFinance m)
|
||||||
|
=> ConfigType
|
||||||
|
-> a
|
||||||
|
-> b
|
||||||
|
-> (Key CommitR -> SqlPersistT m b)
|
||||||
|
-> SqlPersistT m b
|
||||||
|
whenHash t o def f = do
|
||||||
|
let h = hash o
|
||||||
|
hs <- lift $ askDBState kmNewCommits
|
||||||
|
if h `elem` hs then f =<< insert (CommitR h t) else return def
|
||||||
|
|
Loading…
Reference in New Issue