REF don't use so many fields
This commit is contained in:
parent
53e1dde60f
commit
047e9edbb9
|
|
@ -128,6 +128,30 @@ insertBudget Budget {budgetLabel = name, income = is, transfers = es} = do
|
|||
let bals = balanceTransfers txs
|
||||
concat <$> mapM insertBudgetTx bals
|
||||
|
||||
balanceTransfers :: [BudgetTxType] -> [BudgetTx]
|
||||
balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (btWhen . bttTx) ts
|
||||
where
|
||||
initBals =
|
||||
M.fromList $
|
||||
fmap (,0) $
|
||||
L.nub $
|
||||
(fmap (bsAcnt . btTo . bttTx) ts ++ fmap (bsAcnt . btTo . bttTx) ts)
|
||||
updateBal x = M.update (Just . (+ x))
|
||||
lookupBal = M.findWithDefault (error "this should not happen")
|
||||
go bals btt =
|
||||
let tx = bttTx btt
|
||||
from = bsAcnt $ btFrom tx
|
||||
to = bsAcnt $ btTo tx
|
||||
bal = lookupBal to bals
|
||||
x = amtToMove bal (bttType btt) (btValue tx)
|
||||
in (updateBal x to $ updateBal (-x) from bals, tx {btValue = x})
|
||||
-- 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
|
||||
-- target value
|
||||
amtToMove _ FixedAmt x = x
|
||||
amtToMove bal Percent x = -(x / 100 * bal)
|
||||
amtToMove bal Target x = x - bal
|
||||
|
||||
-- TODO allow currency conversions here
|
||||
data BudgetSplit b = BudgetSplit
|
||||
{ bsAcnt :: !AcntID
|
||||
|
|
@ -136,33 +160,30 @@ data BudgetSplit b = BudgetSplit
|
|||
|
||||
data BudgetMeta = BudgetMeta
|
||||
{ bmCommit :: !(Key CommitR)
|
||||
, bmWhen :: !Day
|
||||
, bmCur :: !CurID
|
||||
, bmName :: !T.Text
|
||||
}
|
||||
|
||||
data BudgetTx = BudgetTx
|
||||
{ btMeta :: !BudgetMeta
|
||||
, btWhen :: !Day
|
||||
, btFrom :: !(BudgetSplit IncomeBucket)
|
||||
, btTo :: !(BudgetSplit ExpenseBucket)
|
||||
, btValue :: !Rational
|
||||
, btDesc :: !T.Text
|
||||
}
|
||||
|
||||
data TransferTx = TransferTx
|
||||
{ trxMeta :: !BudgetMeta
|
||||
, trxFrom :: !(BudgetSplit IncomeBucket)
|
||||
, trxTo :: !(BudgetSplit ExpenseBucket)
|
||||
, trxValue :: !Rational
|
||||
, trxType :: AmountType
|
||||
, trxDesc :: !T.Text
|
||||
data BudgetTxType = BudgetTxType
|
||||
{ bttType :: !AmountType
|
||||
, bttTx :: !BudgetTx
|
||||
}
|
||||
|
||||
insertIncome :: MonadFinance m => T.Text -> Income -> SqlPersistT m (EitherErrs [TransferTx])
|
||||
insertIncome :: MonadFinance m => T.Text -> Income -> SqlPersistT m (EitherErrs [BudgetTxType])
|
||||
insertIncome
|
||||
name
|
||||
i@Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal} =
|
||||
whenHash CTIncome i (Right []) $ \c -> do
|
||||
let meta = BudgetMeta c incCurrency name
|
||||
let balRes = balanceIncome i
|
||||
fromRes <- lift $ checkAcntType IncomeT incFrom (\j -> BudgetSplit j . Just)
|
||||
toRes <- lift $ expandTarget incToBal
|
||||
|
|
@ -171,78 +192,76 @@ insertIncome
|
|||
Right (balance, fromFun, to) ->
|
||||
fmap (fmap (concat . concat)) $
|
||||
withDates incWhen $ \day -> do
|
||||
let meta = BudgetMeta c day incCurrency name
|
||||
let fromAllos b =
|
||||
fmap (fmap concat . concatEitherL)
|
||||
. mapM (lift . fromAllo meta (fromFun b))
|
||||
. mapM (lift . fromAllo day meta (fromFun b))
|
||||
pre <- fromAllos PreTax incPretax
|
||||
tax <-
|
||||
concatEitherL
|
||||
<$> mapM (lift . fromTax meta (fromFun IntraTax)) incTaxes
|
||||
<$> mapM (lift . fromTax day meta (fromFun IntraTax)) incTaxes
|
||||
post <- fromAllos PostTax incPosttax
|
||||
let bal =
|
||||
TransferTx
|
||||
{ trxMeta = meta
|
||||
, trxFrom = fromFun PostTax
|
||||
, trxTo = to
|
||||
, trxValue = balance
|
||||
, trxType = FixedAmt
|
||||
, trxDesc = "balance after deductions"
|
||||
BudgetTxType
|
||||
{ bttTx =
|
||||
BudgetTx
|
||||
{ btMeta = meta
|
||||
, btWhen = day
|
||||
, btFrom = fromFun PostTax
|
||||
, btTo = to
|
||||
, btValue = balance
|
||||
, btDesc = "balance after deductions"
|
||||
}
|
||||
, bttType = FixedAmt
|
||||
}
|
||||
return $ concatEithersL [Right [bal], tax, pre, post]
|
||||
|
||||
fromAllo
|
||||
:: MonadFinance m
|
||||
=> BudgetMeta
|
||||
=> Day
|
||||
-> BudgetMeta
|
||||
-> BudgetSplit IncomeBucket
|
||||
-> Allocation
|
||||
-> m (EitherErr [TransferTx])
|
||||
fromAllo meta from Allocation {alloPath, alloAmts} = do
|
||||
-> m (EitherErr [BudgetTxType])
|
||||
fromAllo day meta from Allocation {alloPath, alloAmts} = do
|
||||
-- TODO this is going to be repeated a zillion times (might matter)
|
||||
res <- expandTarget alloPath
|
||||
return $ (\to -> fmap (toBT to) alloAmts) <$> res
|
||||
where
|
||||
toBT to (Amount desc v) =
|
||||
TransferTx
|
||||
{ trxFrom = from
|
||||
, trxTo = to
|
||||
, trxValue = dec2Rat v
|
||||
, trxDesc = desc
|
||||
, trxType = FixedAmt
|
||||
, trxMeta = meta
|
||||
BudgetTxType
|
||||
{ bttTx =
|
||||
BudgetTx
|
||||
{ btFrom = from
|
||||
, btWhen = day
|
||||
, btTo = to
|
||||
, btValue = dec2Rat v
|
||||
, btDesc = desc
|
||||
, btMeta = meta
|
||||
}
|
||||
, bttType = FixedAmt
|
||||
}
|
||||
|
||||
expandTarget :: MonadFinance m => TransferTarget -> m (EitherErr (BudgetSplit ExpenseBucket))
|
||||
expandTarget t = case t of
|
||||
ExpenseTarget i b -> checkAcntType ExpenseT i $ (`BudgetSplit` (Just b))
|
||||
GenericTarget i -> checkAcntTypes (LiabilityT :| [AssetT, EquityT]) i $ (`BudgetSplit` Nothing)
|
||||
|
||||
checkAcntType :: MonadFinance m => AcntType -> AcntID -> (AcntID -> a) -> m (EitherErr a)
|
||||
checkAcntType t = checkAcntTypes (t :| [])
|
||||
|
||||
checkAcntTypes :: MonadFinance m => NE.NonEmpty AcntType -> AcntID -> (AcntID -> a) -> m (EitherErr a)
|
||||
checkAcntTypes ts i f = (go =<<) <$> lookupAccountType i
|
||||
where
|
||||
go t
|
||||
| t `L.elem` ts = Right $ f i
|
||||
| otherwise = Left $ AccountError i t
|
||||
|
||||
fromTax
|
||||
:: MonadFinance m
|
||||
=> BudgetMeta
|
||||
=> Day
|
||||
-> BudgetMeta
|
||||
-> BudgetSplit IncomeBucket
|
||||
-> Tax
|
||||
-> m (EitherErr TransferTx)
|
||||
fromTax meta from Tax {taxAcnt = to, taxValue = v} =
|
||||
-> m (EitherErr BudgetTxType)
|
||||
fromTax day meta from Tax {taxAcnt = to, taxValue = v} =
|
||||
-- TODO this is going to be repeated a zillion times (might matter)
|
||||
checkAcntType ExpenseT to $ \to_ ->
|
||||
TransferTx
|
||||
{ trxFrom = from
|
||||
, trxTo = BudgetSplit to_ (Just Fixed)
|
||||
, trxValue = dec2Rat v
|
||||
, trxDesc = ""
|
||||
, trxType = FixedAmt
|
||||
, trxMeta = meta
|
||||
BudgetTxType
|
||||
{ bttTx =
|
||||
BudgetTx
|
||||
{ btFrom = from
|
||||
, btWhen = day
|
||||
, btTo = BudgetSplit to_ (Just Fixed)
|
||||
, btValue = dec2Rat v
|
||||
, btDesc = ""
|
||||
, btMeta = meta
|
||||
}
|
||||
, bttType = FixedAmt
|
||||
}
|
||||
|
||||
balanceIncome :: Income -> EitherErr Rational
|
||||
|
|
@ -265,43 +284,16 @@ sumAllocation = sum . fmap (dec2Rat . amtValue) . alloAmts
|
|||
sumTaxes :: [Tax] -> Rational
|
||||
sumTaxes = sum . fmap (dec2Rat . taxValue)
|
||||
|
||||
expandTransfers :: MonadFinance m => T.Text -> [Transfer] -> SqlPersistT m (EitherErrs [TransferTx])
|
||||
expandTransfers
|
||||
:: MonadFinance m
|
||||
=> T.Text
|
||||
-> [Transfer]
|
||||
-> SqlPersistT m (EitherErrs [BudgetTxType])
|
||||
expandTransfers name ts = do
|
||||
txs <- mapM (expandTransfer name) ts
|
||||
return $ L.sortOn (bmWhen . trxMeta) . concat <$> concatEithersL txs
|
||||
return $ L.sortOn (btWhen . bttTx) . concat <$> concatEithersL txs
|
||||
|
||||
balanceTransfers :: [TransferTx] -> [BudgetTx]
|
||||
balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (bmWhen . trxMeta) ts
|
||||
where
|
||||
initBals =
|
||||
M.fromList $
|
||||
fmap (,0) $
|
||||
L.nub $
|
||||
(fmap (bsAcnt . trxTo) ts ++ fmap (bsAcnt . trxTo) ts)
|
||||
updateBal x = M.update (Just . (+ x))
|
||||
lookupBal = M.findWithDefault (error "this should not happen")
|
||||
go bals TransferTx {trxMeta, trxFrom, trxTo, trxValue, trxType, trxDesc} =
|
||||
let from = bsAcnt trxFrom
|
||||
to = bsAcnt trxTo
|
||||
bal = lookupBal to bals
|
||||
x = amtToMove bal trxType trxValue
|
||||
t =
|
||||
BudgetTx
|
||||
{ btMeta = trxMeta
|
||||
, btFrom = trxFrom
|
||||
, btTo = trxTo
|
||||
, btValue = x
|
||||
, btDesc = trxDesc
|
||||
}
|
||||
in (updateBal x to $ updateBal (-x) from bals, t)
|
||||
-- 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
|
||||
-- target value
|
||||
amtToMove _ FixedAmt x = x
|
||||
amtToMove bal Percent x = -(x / 100 * bal)
|
||||
amtToMove bal Target x = x - bal
|
||||
|
||||
expandTransfer :: MonadFinance m => T.Text -> Transfer -> SqlPersistT m (EitherErrs [TransferTx])
|
||||
expandTransfer :: MonadFinance m => T.Text -> Transfer -> SqlPersistT m (EitherErrs [BudgetTxType])
|
||||
expandTransfer name t@Transfer {transAmounts, transTo, transCurrency, transFrom} =
|
||||
whenHash CTExpense t (Right []) $ \key ->
|
||||
fmap (fmap concat . concatEithersL) $
|
||||
|
|
@ -313,27 +305,30 @@ expandTransfer name t@Transfer {transAmounts, transTo, transCurrency, transFrom}
|
|||
Right to -> withDates pat $ \day ->
|
||||
let meta =
|
||||
BudgetMeta
|
||||
{ bmWhen = day
|
||||
, bmCur = transCurrency
|
||||
{ bmCur = transCurrency
|
||||
, bmCommit = key
|
||||
, bmName = name
|
||||
}
|
||||
tx =
|
||||
TransferTx
|
||||
{ trxMeta = meta
|
||||
, trxFrom = BudgetSplit transFrom Nothing
|
||||
, trxTo = to
|
||||
, trxValue = dec2Rat v
|
||||
, trxType = atype
|
||||
, trxDesc = desc
|
||||
BudgetTxType
|
||||
{ bttTx =
|
||||
BudgetTx
|
||||
{ btMeta = meta
|
||||
, btWhen = day
|
||||
, btFrom = BudgetSplit transFrom Nothing
|
||||
, btTo = to
|
||||
, btValue = dec2Rat v
|
||||
, btDesc = desc
|
||||
}
|
||||
, bttType = atype
|
||||
}
|
||||
in return $ Right tx
|
||||
|
||||
insertBudgetTx :: MonadFinance m => BudgetTx -> SqlPersistT m [InsertError]
|
||||
insertBudgetTx BudgetTx {btFrom, btTo, btMeta, btValue, btDesc} = do
|
||||
insertBudgetTx BudgetTx {btFrom, btTo, btMeta, btValue, btDesc, btWhen} = do
|
||||
res <- lift $ splitPair (bsAcnt btFrom) (bsAcnt btTo) (bmCur btMeta) btValue
|
||||
unlessLefts_ res $ \(sFrom, sTo) -> do
|
||||
k <- insert $ TransactionR (bmCommit btMeta) (bmWhen btMeta) btDesc
|
||||
k <- insert $ TransactionR (bmCommit btMeta) btWhen btDesc
|
||||
insertBudgetLabel name k IncomeBucketR sFrom btFrom
|
||||
insertBudgetLabel name k ExpenseBucketR sTo btTo
|
||||
where
|
||||
|
|
@ -373,6 +368,36 @@ splitPair from to cur val = do
|
|||
, sCurrency = cur
|
||||
}
|
||||
|
||||
expandTarget
|
||||
:: MonadFinance m
|
||||
=> TransferTarget
|
||||
-> m (EitherErr (BudgetSplit ExpenseBucket))
|
||||
expandTarget t = case t of
|
||||
ExpenseTarget i b -> checkAcntType ExpenseT i $ (`BudgetSplit` (Just b))
|
||||
GenericTarget i ->
|
||||
checkAcntTypes (LiabilityT :| [AssetT, EquityT]) i $
|
||||
(`BudgetSplit` Nothing)
|
||||
|
||||
checkAcntType
|
||||
:: MonadFinance m
|
||||
=> AcntType
|
||||
-> AcntID
|
||||
-> (AcntID -> a)
|
||||
-> m (EitherErr a)
|
||||
checkAcntType t = checkAcntTypes (t :| [])
|
||||
|
||||
checkAcntTypes
|
||||
:: MonadFinance m
|
||||
=> NE.NonEmpty AcntType
|
||||
-> AcntID
|
||||
-> (AcntID -> a)
|
||||
-> m (EitherErr a)
|
||||
checkAcntTypes ts i f = (go =<<) <$> lookupAccountType i
|
||||
where
|
||||
go t
|
||||
| t `L.elem` ts = Right $ f i
|
||||
| otherwise = Left $ AccountError i t
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- statements
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue