WIP assign buckets more sanely

This commit is contained in:
Nathan Dwarshuis 2023-02-12 21:52:41 -05:00
parent a16f6fbdd2
commit 53e1dde60f
6 changed files with 173 additions and 93 deletions

View File

@ -193,9 +193,18 @@ let TimeAmount = { taWhen : DatePat, taAmt : Amount, taAmtType : AmountType }
let Tax = { taxAcnt : AcntID, taxValue : Decimal }
let TransferTarget =
< ExpenseTarget :
{ _1xtarget :
{- this is the only place expense accounts may be specified -}
AcntID
, _2xtarget : ExpenseBucket
}
| GenericTarget : AcntID
>
let Allocation =
{ alloPath : AcntID
, alloBucket : ExpenseBucket
{ alloPath : TransferTarget
, alloAmts : List Amount
, alloCurrency : CurID
}
@ -204,17 +213,19 @@ let Income =
{ incGross : Decimal
, incCurrency : CurID
, incWhen : DatePat
, incFrom : AcntID
, incFrom :
{- this must be an income AcntID, and is the only place income
accounts may be specified in the entire budget -}
AcntID
, incPretax : List Allocation
, incTaxes : List Tax
, incPosttax : List Allocation
, incToBal : AcntID
, incToBal : TransferTarget
}
let Transfer =
{ transFrom : AcntID
, transTo : AcntID
, transBucket : ExpenseBucket
, transTo : TransferTarget
, transAmounts : List TimeAmount
, transCurrency : CurID
}
@ -267,4 +278,5 @@ in { CurID
, Amount
, TimeAmount
, AmountType
, TransferTarget
}

View File

@ -59,7 +59,7 @@ IncomeBucketR sql=income_buckets
deriving Show Eq
|]
type AccountMap = M.Map AcntID (AccountRId, AcntSign)
type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
type CurrencyMap = M.Map CurID CurrencyRId

View File

@ -212,7 +212,7 @@ tree2Entity t parents name des =
tree2Records
:: AcntType
-> AccountTree
-> ([Entity AccountR], [AccountPathR], [(AcntPath, (AccountRId, AcntSign))])
-> ([Entity AccountR], [AccountPathR], [(AcntPath, (AccountRId, AcntSign, AcntType))])
tree2Records t = go []
where
go ps (Placeholder d n cs) =
@ -227,7 +227,7 @@ tree2Records t = go []
k = entityKey e
in ( [acnt k n (fmap snd ps) d]
, expand k $ fmap fst ps
, [(AcntPath t $ reverse $ n : fmap snd ps, (k, sign))]
, [(AcntPath t $ reverse $ n : fmap snd ps, (k, sign, t))]
)
toPath = T.intercalate "/" . (atName t :) . reverse
acnt k n ps = Entity k . AccountR n (toPath ps)

View File

@ -7,6 +7,7 @@ where
import Data.Hashable
import Database.Persist.Class
import Database.Persist.Sql hiding (Single, Statement)
import GHC.Utils.Misc hiding (split)
import Internal.Database.Model
import Internal.Statement
import Internal.Types hiding (sign)
@ -14,6 +15,7 @@ import Internal.Utils
import RIO hiding (to)
import qualified RIO.List as L
import qualified RIO.Map as M
import qualified RIO.NonEmpty as NE
import qualified RIO.Text as T
import RIO.Time
@ -95,12 +97,13 @@ dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7
withDates
:: MonadFinance m
=> DatePat
-> (Day -> SqlPersistT m a)
-> (Day -> SqlPersistT m (EitherErrs a))
-> SqlPersistT m (EitherErrs [a])
withDates dp f = do
bounds <- lift $ askDBState kmBudgetInterval
let days = expandDatePat bounds dp
mapM (mapM f) days
case expandDatePat bounds dp of
Left es -> return $ Left es
Right days -> concatEithersL <$> mapM f days
--------------------------------------------------------------------------------
-- budget
@ -159,55 +162,88 @@ insertIncome :: MonadFinance m => T.Text -> Income -> SqlPersistT m (EitherErrs
insertIncome
name
i@Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal} =
whenHash CTIncome i (Right []) $ \c -> case (balanceIncome i) of
Left e -> return $ Left [e]
Right balance ->
fmap (fmap concat) $ withDates incWhen $ \day -> do
let meta = BudgetMeta c day incCurrency name
let fromAllos b = concatMap (fromAllo meta incFrom (Just b))
let pre = fromAllos PreTax incPretax
let tax = fmap (fromTax meta incFrom) incTaxes
let post = fromAllos PostTax incPosttax
let bal =
TransferTx
{ trxMeta = meta
, trxFrom = BudgetSplit incFrom $ Just PostTax
, trxTo = BudgetSplit incToBal Nothing
, trxValue = balance
, trxType = FixedAmt
, trxDesc = "balance after deductions"
}
return $ bal : (pre ++ tax ++ post)
whenHash CTIncome i (Right []) $ \c -> do
let balRes = balanceIncome i
fromRes <- lift $ checkAcntType IncomeT incFrom (\j -> BudgetSplit j . Just)
toRes <- lift $ expandTarget incToBal
case concatEither3 balRes fromRes toRes (,,) of
Left es -> return $ Left es
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))
pre <- fromAllos PreTax incPretax
tax <-
concatEitherL
<$> mapM (lift . fromTax 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"
}
return $ concatEithersL [Right [bal], tax, pre, post]
fromAllo
:: BudgetMeta
-> AcntID
-> Maybe IncomeBucket
:: MonadFinance m
=> BudgetMeta
-> BudgetSplit IncomeBucket
-> Allocation
-> [TransferTx]
fromAllo meta from ib Allocation {alloPath, alloAmts, alloBucket} =
fmap (toBT alloPath) alloAmts
-> m (EitherErr [TransferTx])
fromAllo 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 = BudgetSplit from ib
, trxTo = BudgetSplit to $ Just alloBucket
{ trxFrom = from
, trxTo = to
, trxValue = dec2Rat v
, trxDesc = desc
, trxType = FixedAmt
, trxMeta = meta
}
fromTax :: BudgetMeta -> AcntID -> Tax -> TransferTx
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
-> BudgetSplit IncomeBucket
-> Tax
-> m (EitherErr TransferTx)
fromTax meta from Tax {taxAcnt = to, taxValue = v} =
TransferTx
{ trxFrom = BudgetSplit from (Just IntraTax)
, trxTo = BudgetSplit to (Just Fixed)
, trxValue = dec2Rat v
, trxDesc = ""
, trxType = FixedAmt
, trxMeta = meta
}
-- 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
}
balanceIncome :: Income -> EitherErr Rational
balanceIncome
@ -234,7 +270,6 @@ expandTransfers name ts = do
txs <- mapM (expandTransfer name) ts
return $ L.sortOn (bmWhen . trxMeta) . concat <$> concatEithersL txs
-- TODO the entire budget needs to have this process applied to it
balanceTransfers :: [TransferTx] -> [BudgetTx]
balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (bmWhen . trxMeta) ts
where
@ -268,30 +303,35 @@ balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (bmWhen . trxMeta
expandTransfer :: MonadFinance m => T.Text -> Transfer -> SqlPersistT m (EitherErrs [TransferTx])
expandTransfer name t@Transfer {transAmounts, transTo, transCurrency, transFrom} =
whenHash CTExpense t (Right []) $ \key -> do
res <- forM transAmounts $ \(TimeAmount (Amount desc v) atype pat) ->
withDates pat $ \day ->
let meta =
BudgetMeta
{ bmWhen = day
, bmCur = transCurrency
, bmCommit = key
, bmName = name
}
in return $
TransferTx
{ trxMeta = meta
, trxFrom = BudgetSplit transFrom Nothing
, trxTo = BudgetSplit transTo Nothing
, trxValue = dec2Rat v
, trxType = atype
, trxDesc = desc
}
return $ concat <$> concatEithersL res
whenHash CTExpense t (Right []) $ \key ->
fmap (fmap concat . concatEithersL) $
forM transAmounts $ \(TimeAmount (Amount desc v) atype pat) -> do
-- TODO this is going to be repeated a zillion times (might matter)
res <- lift $ expandTarget transTo
case res of
Left e -> return $ Left [e]
Right to -> withDates pat $ \day ->
let meta =
BudgetMeta
{ bmWhen = day
, bmCur = transCurrency
, bmCommit = key
, bmName = name
}
tx =
TransferTx
{ trxMeta = meta
, trxFrom = BudgetSplit transFrom Nothing
, trxTo = to
, trxValue = dec2Rat v
, trxType = atype
, trxDesc = desc
}
in return $ Right tx
insertBudgetTx :: MonadFinance m => BudgetTx -> SqlPersistT m [InsertError]
insertBudgetTx BudgetTx {btFrom, btTo, btMeta, btValue, btDesc} = do
res <- splitPair (bsAcnt btFrom) (bsAcnt btTo) (bmCur btMeta) btValue
res <- lift $ splitPair (bsAcnt btFrom) (bsAcnt btTo) (bmCur btMeta) btValue
unlessLefts_ res $ \(sFrom, sTo) -> do
k <- insert $ TransactionR (bmCommit btMeta) (bmWhen btMeta) btDesc
insertBudgetLabel name k IncomeBucketR sFrom btFrom
@ -318,7 +358,7 @@ splitPair
-> AcntID
-> CurID
-> Rational
-> SqlPersistT m (EitherErrs (KeySplit, KeySplit))
-> m (EitherErrs (KeySplit, KeySplit))
splitPair from to cur val = do
s1 <- split from (-val)
s2 <- split to val
@ -358,7 +398,7 @@ insertManual
-- let days = expandDatePat bounds dp
let dayRes = expandDatePat bounds dp
unlessLefts dayRes $ \days -> do
txRes <- mapM tx days
txRes <- mapM (lift . tx) days
unlessLefts_ (concatEithersL txRes) $ mapM_ (insertTx c)
where
tx day = txPair day from to u (dec2Rat v) e
@ -369,7 +409,7 @@ insertImport i = whenHash CTImport i [] $ \c -> do
-- transactions will be desired
recoverIO (lift $ readImport i) $ \r -> unlessLefts r $ \bs -> do
bounds <- expandBounds <$> lift (askDBState kmStatementInterval)
res <- mapM resolveTx $ filter (inBounds bounds . txDate) bs
res <- mapM (lift . resolveTx) $ filter (inBounds bounds . txDate) bs
unlessLefts_ (concatEithersL res) $ mapM_ (insertTx c)
where
recoverIO x rest = do
@ -391,7 +431,7 @@ txPair
-> CurID
-> Rational
-> T.Text
-> SqlPersistT m (EitherErrs KeyTx)
-> m (EitherErrs KeyTx)
txPair day from to cur val desc = resolveTx tx
where
split a v = Split {sAcnt = a, sValue = v, sComment = "", sCurrency = cur}
@ -403,12 +443,12 @@ txPair day from to cur val desc = resolveTx tx
, txSplits = [split from (-val), split to val]
}
resolveTx :: MonadFinance m => BalTx -> SqlPersistT m (EitherErrs KeyTx)
resolveTx :: MonadFinance m => BalTx -> m (EitherErrs KeyTx)
resolveTx t@Tx {txSplits = ss} = do
res <- concatEithersL <$> mapM resolveSplit ss
return $ fmap (\kss -> t {txSplits = kss}) res
resolveSplit :: MonadFinance m => BalSplit -> SqlPersistT m (EitherErrs KeySplit)
resolveSplit :: MonadFinance m => BalSplit -> m (EitherErrs KeySplit)
resolveSplit s@Split {sAcnt = p, sCurrency = c, sValue = v} = do
aid <- lookupAccountKey p
cid <- lookupCurrency c
@ -431,17 +471,20 @@ insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m
insertSplit t Split {sAcnt = aid, sCurrency = cid, sValue = v, sComment = c} = do
insert $ SplitR t cid aid c v
lookupAccount :: MonadFinance m => AcntID -> SqlPersistT m (EitherErr (Key AccountR, AcntSign))
lookupAccount p = lookupErr (DBKey AcntField) p <$> lift (askDBState kmAccount)
lookupAccount :: MonadFinance m => AcntID -> m (EitherErr (Key AccountR, AcntSign, AcntType))
lookupAccount p = lookupErr (DBKey AcntField) p <$> (askDBState kmAccount)
lookupAccountKey :: MonadFinance m => AcntID -> SqlPersistT m (EitherErr (Key AccountR))
lookupAccountKey = fmap (fmap fst) . lookupAccount
lookupAccountKey :: MonadFinance m => AcntID -> m (EitherErr (Key AccountR))
lookupAccountKey = (fmap (fmap fstOf3)) . lookupAccount
lookupAccountSign :: MonadFinance m => AcntID -> SqlPersistT m (EitherErr AcntSign)
lookupAccountSign = fmap (fmap snd) . lookupAccount
lookupAccountSign :: MonadFinance m => AcntID -> m (EitherErr AcntSign)
lookupAccountSign = fmap (fmap sndOf3) . lookupAccount
lookupCurrency :: MonadFinance m => T.Text -> SqlPersistT m (EitherErr (Key CurrencyR))
lookupCurrency c = lookupErr (DBKey CurField) c <$> lift (askDBState kmCurrency)
lookupAccountType :: MonadFinance m => AcntID -> m (EitherErr AcntType)
lookupAccountType = fmap (fmap thdOf3) . lookupAccount
lookupCurrency :: MonadFinance m => T.Text -> m (EitherErr (Key CurrencyR))
lookupCurrency c = lookupErr (DBKey CurField) c <$> (askDBState kmCurrency)
-- TODO this hashes twice (not that it really matters)
whenHash

View File

@ -34,6 +34,7 @@ makeHaskellTypesWith
, MultipleConstructors "ExpenseBucket" "(./dhall/Types.dhall).ExpenseBucket"
, MultipleConstructors "IncomeBucket" "(./dhall/Types.dhall).IncomeBucket"
, MultipleConstructors "AmountType" "(./dhall/Types.dhall).AmountType"
, MultipleConstructors "TransferTarget" "(./dhall/Types.dhall).TransferTarget"
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
, SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
, SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
@ -50,8 +51,8 @@ makeHaskellTypesWith
, SingleConstructor "TimeAmount" "TimeAmount" "(./dhall/Types.dhall).TimeAmount"
, SingleConstructor "Allocation" "Allocation" "(./dhall/Types.dhall).Allocation"
, SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income"
, SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
, SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget"
, SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
]
-------------------------------------------------------------------------------
@ -300,6 +301,10 @@ deriving instance Eq TimeAmount
deriving instance Hashable TimeAmount
deriving instance Eq TransferTarget
deriving instance Hashable TransferTarget
deriving instance Eq Transfer
deriving instance Hashable Transfer
@ -582,6 +587,7 @@ data PatternSuberr = ZeroLength | ZeroRepeats deriving (Show)
data InsertError
= RegexError !T.Text
| MatchValPrecisionError !Natural !Natural
| AccountError !AcntID !AcntType
| InsertIOError !T.Text
| ParseError !T.Text
| ConversionError !T.Text

View File

@ -9,10 +9,13 @@ module Internal.Utils
, leftToMaybe
, dec2Rat
, concatEithers2
, concatEithers3
, concatEither3
, concatEither2
, concatEitherL
, concatEithersL
, concatEither2M
, concatEithers2M
, parseRational
, showError
, unlessLeft_
@ -23,7 +26,8 @@ module Internal.Utils
, showT
, lookupErr
, gregorians
, uncurry3
-- , uncurry3
, xGregToDay
, plural
, compileMatch
@ -313,6 +317,8 @@ showError other = (: []) $ case other of
where
showGreg (Just g) = showGregorian_ g
showGreg Nothing = "Inf"
-- TODO define
(AccountError _ _) -> undefined
(PatternError s b r p) -> T.unwords [msg, "in pattern: ", pat]
where
pat =
@ -478,6 +484,11 @@ concatEither2 a b fun = case (a, b) of
(Right a_, Right b_) -> Right $ fun a_ b_
_ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b]
concatEither2M :: Monad m => Either x a -> Either x b -> (a -> b -> m c) -> m (Either [x] c)
concatEither2M a b fun = case (a, b) of
(Right a_, Right b_) -> Right <$> fun a_ b_
_ -> return $ Left $ catMaybes [leftToMaybe a, leftToMaybe b]
concatEither3 :: Either x a -> Either x b -> Either x c -> (a -> b -> c -> d) -> Either [x] d
concatEither3 a b c fun = case (a, b, c) of
(Right a_, Right b_, Right c_) -> Right $ fun a_ b_ c_
@ -486,13 +497,21 @@ concatEither3 a b c fun = case (a, b, c) of
concatEithers2 :: Either [x] a -> Either [x] b -> (a -> b -> c) -> Either [x] c
concatEithers2 a b = merge . concatEither2 a b
-- concatEithers3
-- :: Either [x] a
-- -> Either [x] b
-- -> Either [x] c
-- -> (a -> b -> c -> d)
-- -> Either [x] d
-- concatEithers3 a b c = merge . concatEither3 a b c
concatEithers2M
:: Monad m
=> Either [x] a
-> Either [x] b
-> (a -> b -> m c)
-> m (Either [x] c)
concatEithers2M a b = fmap merge . concatEither2M a b
concatEithers3
:: Either [x] a
-> Either [x] b
-> Either [x] c
-> (a -> b -> c -> d)
-> Either [x] d
concatEithers3 a b c = merge . concatEither3 a b c
concatEitherL :: [Either x a] -> Either [x] [a]
concatEitherL as = case partitionEithers as of