FIX don't hash budget components (since they are interdependent)
This commit is contained in:
parent
6e2598b274
commit
d89b63e59a
|
@ -95,14 +95,11 @@ hashConfig
|
|||
Config_
|
||||
{ budget = bs
|
||||
, statements = ss
|
||||
} =
|
||||
concatMap budgetHashes bs ++ (hash <$> ms) ++ (hash <$> ps)
|
||||
} = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps)
|
||||
where
|
||||
(ms, ps) = partitionEithers $ fmap go ss
|
||||
go (StmtManual x) = Left x
|
||||
go (StmtImport x) = Right x
|
||||
budgetHashes Budget {transfers = xs, income = is} =
|
||||
(hash <$> xs) ++ (hash <$> is)
|
||||
|
||||
setDiff :: Eq a => [a] -> [a] -> ([a], [a])
|
||||
-- setDiff = setDiff' (==)
|
||||
|
|
|
@ -119,9 +119,10 @@ withDates dp f = do
|
|||
-- 5. insert all transactions
|
||||
|
||||
insertBudget :: MonadFinance m => Budget -> SqlPersistT m [InsertError]
|
||||
insertBudget Budget {budgetLabel = name, income = is, transfers = es, shadowTransfers = ss} = do
|
||||
res1 <- mapM (insertIncome name) is
|
||||
res2 <- expandTransfers name es
|
||||
insertBudget b@(Budget {budgetLabel = name, income = is, transfers = es, shadowTransfers = ss}) =
|
||||
whenHash CTBudget b [] $ \key -> do
|
||||
res1 <- mapM (insertIncome key name) is
|
||||
res2 <- expandTransfers key name es
|
||||
unlessLefts (concatEithers2 (fmap concat $ concatEithersL res1) res2 (++)) $
|
||||
\txs -> do
|
||||
unlessLefts (addShadowTransfers ss txs) $ \shadow -> do
|
||||
|
@ -173,13 +174,15 @@ shadowMatches ShadowMatch {smFrom, smTo, smDate, smVal} tx = do
|
|||
(if asInclude then id else not) $ x `elem` asList
|
||||
|
||||
balanceTransfers :: [BudgetTxType] -> [BudgetTx]
|
||||
balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (btWhen . bttTx) ts
|
||||
balanceTransfers ts =
|
||||
snd $ L.mapAccumR go initBals $ reverse $ L.sortOn (btWhen . bttTx) ts
|
||||
where
|
||||
initBals =
|
||||
M.fromList $
|
||||
fmap (,0) $
|
||||
L.nub $
|
||||
(fmap (btTo . bttTx) ts ++ fmap (btTo . bttTx) ts)
|
||||
fmap (btTo . bttTx) ts
|
||||
++ fmap (btFrom . bttTx) ts
|
||||
updateBal x = M.update (Just . (+ x))
|
||||
lookupBal = M.findWithDefault (error "this should not happen")
|
||||
go bals btt =
|
||||
|
@ -197,7 +200,7 @@ balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (btWhen . bttTx)
|
|||
amtToMove bal Target x = x - bal
|
||||
|
||||
data BudgetMeta = BudgetMeta
|
||||
{ bmCommit :: !(Key CommitR)
|
||||
{ bmCommit :: !CommitRId
|
||||
, bmCur :: !BudgetCurrency
|
||||
, bmName :: !T.Text
|
||||
}
|
||||
|
@ -216,12 +219,13 @@ data BudgetTxType = BudgetTxType
|
|||
, bttTx :: !BudgetTx
|
||||
}
|
||||
|
||||
insertIncome :: MonadFinance m => T.Text -> Income -> SqlPersistT m (EitherErrs [BudgetTxType])
|
||||
insertIncome :: MonadFinance m => CommitRId -> T.Text -> Income -> SqlPersistT m (EitherErrs [BudgetTxType])
|
||||
insertIncome
|
||||
key
|
||||
name
|
||||
i@Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal} =
|
||||
whenHash CTIncome i (Right []) $ \c -> do
|
||||
let meta = BudgetMeta c (NoX incCurrency) name
|
||||
i@Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal} = do
|
||||
-- whenHash CTIncome i (Right []) $ \c -> do
|
||||
let meta = BudgetMeta key (NoX incCurrency) name
|
||||
let balRes = balanceIncome i
|
||||
fromRes <- lift $ checkAcntType IncomeT $ taAcnt incFrom
|
||||
case concatEither2 balRes fromRes (,) of
|
||||
|
@ -325,16 +329,17 @@ sumTaxes = sum . fmap (dec2Rat . taxValue)
|
|||
|
||||
expandTransfers
|
||||
:: MonadFinance m
|
||||
=> T.Text
|
||||
=> CommitRId
|
||||
-> T.Text
|
||||
-> [Transfer]
|
||||
-> SqlPersistT m (EitherErrs [BudgetTxType])
|
||||
expandTransfers name ts = do
|
||||
txs <- mapM (expandTransfer name) ts
|
||||
expandTransfers key name ts = do
|
||||
txs <- mapM (expandTransfer key name) ts
|
||||
return $ L.sortOn (btWhen . bttTx) . concat <$> concatEithersL txs
|
||||
|
||||
expandTransfer :: MonadFinance m => T.Text -> Transfer -> SqlPersistT m (EitherErrs [BudgetTxType])
|
||||
expandTransfer name t@Transfer {transAmounts, transTo, transCurrency, transFrom} =
|
||||
whenHash CTExpense t (Right []) $ \key ->
|
||||
expandTransfer :: MonadFinance m => CommitRId -> T.Text -> Transfer -> SqlPersistT m (EitherErrs [BudgetTxType])
|
||||
expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} =
|
||||
-- whenHash CTExpense t (Right []) $ \key ->
|
||||
fmap (fmap concat . concatEithersL) $
|
||||
forM transAmounts $ \(TimeAmount (Amount desc v) atype pat) -> do
|
||||
withDates pat $ \day ->
|
||||
|
|
|
@ -524,7 +524,7 @@ data ConfigHashes = ConfigHashes
|
|||
, chImport :: ![Int]
|
||||
}
|
||||
|
||||
data ConfigType = CTIncome | CTExpense | CTShadow | CTManual | CTImport
|
||||
data ConfigType = CTBudget | CTManual | CTImport
|
||||
deriving (Eq, Show, Read, Enum)
|
||||
|
||||
instance PersistFieldSql ConfigType where
|
||||
|
|
|
@ -350,7 +350,7 @@ showError other = (: []) $ case other of
|
|||
(MatchValPrecisionError d p) ->
|
||||
T.unwords ["Match denominator", showT d, "must be less than", showT p]
|
||||
(LookupError t f) ->
|
||||
T.unwords ["Could not find field", singleQuote f, "when resolving", what]
|
||||
T.unwords ["Could not find field", f, "when resolving", what]
|
||||
where
|
||||
what = case t of
|
||||
SplitIDField st -> T.unwords ["split", idName st, "ID"]
|
||||
|
|
Loading…
Reference in New Issue