ENH allow multiple budgets
This commit is contained in:
parent
b9a389454f
commit
1e5f40d730
|
@ -163,7 +163,7 @@ runSync c = do
|
|||
Left es -> throwIO $ InsertException es
|
||||
Right s -> do
|
||||
flip runReaderT (s $ takeDirectory c) $ do
|
||||
es1 <- insertBudget $ budget config
|
||||
es1 <- concat <$> mapM insertBudget (budget config)
|
||||
es2 <- insertStatements config
|
||||
let es = es1 ++ es2
|
||||
unless (null es) $ throwIO $ InsertException es
|
||||
|
|
|
@ -210,7 +210,8 @@ let Transfer =
|
|||
, transCurrency : CurID
|
||||
}
|
||||
|
||||
let Budget = { name : Text, income : List Income, transfers : List Transfer }
|
||||
let Budget =
|
||||
{ budgetLabel : Text, income : List Income, transfers : List Transfer }
|
||||
|
||||
in { CurID
|
||||
, AcntID
|
||||
|
|
|
@ -4,7 +4,7 @@ let List/map =
|
|||
|
||||
let T =
|
||||
./Types.dhall
|
||||
sha256:b29c40e8680e3bd2992180b1165a42f6cde1198cdc7efa4fd115e9e25eef50ea
|
||||
sha256:27c65b31fe1b0dd58ff03ec0a37648f586914c81b81e5f33d3eac5a465475f2b
|
||||
|
||||
let nullSplit =
|
||||
\(a : T.SplitAcnt) ->
|
||||
|
|
|
@ -102,14 +102,16 @@ nukeTables = do
|
|||
hashConfig :: Config -> [Int]
|
||||
hashConfig
|
||||
Config_
|
||||
{ budget = Budget {transfers = xs, income = is}
|
||||
{ budget = bs
|
||||
, statements = ss
|
||||
} =
|
||||
(hash <$> xs) ++ (hash <$> is) ++ (hash <$> ms) ++ (hash <$> ps)
|
||||
concatMap budgetHashes 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' (==)
|
||||
|
|
|
@ -103,9 +103,9 @@ withDates dp f = do
|
|||
-- budget
|
||||
|
||||
insertBudget :: MonadUnliftIO m => Budget -> MappingT m [InsertError]
|
||||
insertBudget Budget {income = is, transfers = es} = do
|
||||
es1 <- mapM insertIncome is
|
||||
es2 <- mapM insertTransfer es
|
||||
insertBudget Budget {budgetLabel = name, income = is, transfers = es} = do
|
||||
es1 <- mapM (insertIncome name) is
|
||||
es2 <- mapM (insertTransfer name) es
|
||||
return $ concat $ es1 ++ es2
|
||||
|
||||
-- TODO this hashes twice (not that it really matters)
|
||||
|
@ -131,6 +131,7 @@ data BudgetMeta = BudgetMeta
|
|||
{ bmCommit :: !(Key CommitR)
|
||||
, bmWhen :: !Day
|
||||
, bmCur :: !CurID
|
||||
, bmName :: !T.Text
|
||||
}
|
||||
|
||||
data BudgetTx = BudgetTx
|
||||
|
@ -138,15 +139,15 @@ data BudgetTx = BudgetTx
|
|||
, btFrom :: !(BudgetSplit IncomeBucket)
|
||||
, btTo :: !(BudgetSplit ExpenseBucket)
|
||||
, btValue :: !Rational
|
||||
, btName :: !T.Text
|
||||
, btDesc :: !T.Text
|
||||
}
|
||||
|
||||
insertIncome :: MonadUnliftIO m => Income -> MappingT m [InsertError]
|
||||
insertIncome i@Income {..} =
|
||||
insertIncome :: MonadUnliftIO m => T.Text -> Income -> MappingT m [InsertError]
|
||||
insertIncome name i@Income {..} =
|
||||
whenHash CTIncome i [] $ \c ->
|
||||
unlessLeft (balanceIncome i) $ \balance -> do
|
||||
res <- withDates incWhen $ \day -> do
|
||||
let meta = BudgetMeta c day incCurrency
|
||||
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
|
||||
|
@ -157,7 +158,7 @@ insertIncome i@Income {..} =
|
|||
, btFrom = BudgetSplit incFrom $ Just PostTax
|
||||
, btTo = BudgetSplit incToBal Nothing
|
||||
, btValue = balance
|
||||
, btName = "balance after deductions"
|
||||
, btDesc = "balance after deductions"
|
||||
}
|
||||
fmap concat $ mapM insertBudgetTx $ bal : (pre ++ tax ++ post)
|
||||
unlessLefts res $ return . concat
|
||||
|
@ -175,7 +176,7 @@ fromAllo meta from ib Allocation {..} = fmap (toBT alloPath) alloAmts
|
|||
{ btFrom = BudgetSplit from ib
|
||||
, btTo = BudgetSplit to $ Just alloBucket
|
||||
, btValue = dec2Rat v
|
||||
, btName = desc
|
||||
, btDesc = desc
|
||||
, btMeta = meta
|
||||
}
|
||||
|
||||
|
@ -185,7 +186,7 @@ fromTax meta from Tax {taxAcnt = to, taxValue = v} =
|
|||
{ btFrom = BudgetSplit from (Just IntraTax)
|
||||
, btTo = BudgetSplit to (Just Fixed)
|
||||
, btValue = dec2Rat v
|
||||
, btName = ""
|
||||
, btDesc = ""
|
||||
, btMeta = meta
|
||||
}
|
||||
|
||||
|
@ -209,36 +210,51 @@ sumAllocation = sum . fmap (dec2Rat . amtValue) . alloAmts
|
|||
sumTaxes :: [Tax] -> Rational
|
||||
sumTaxes = sum . fmap (dec2Rat . taxValue)
|
||||
|
||||
insertTransfer :: MonadUnliftIO m => Transfer -> MappingT m [InsertError]
|
||||
insertTransfer t@Transfer {..} =
|
||||
insertTransfer :: MonadUnliftIO m => T.Text -> Transfer -> MappingT m [InsertError]
|
||||
insertTransfer name t@Transfer {..} =
|
||||
fmap concat $ whenHash CTExpense t [] $ \key -> do
|
||||
forM transAmounts $ \(TimeAmount amt pat) -> do
|
||||
res <- withDates pat $ \day -> insertBudgetTx $ budgetTx amt day key
|
||||
unlessLefts res $ return . concat
|
||||
where
|
||||
meta d c = BudgetMeta {bmWhen = d, bmCur = transCurrency, bmCommit = c}
|
||||
meta d c =
|
||||
BudgetMeta
|
||||
{ bmWhen = d
|
||||
, bmCur = transCurrency
|
||||
, bmCommit = c
|
||||
, bmName = name
|
||||
}
|
||||
budgetTx (Amount desc v) d c =
|
||||
BudgetTx
|
||||
{ btMeta = meta d c
|
||||
, btFrom = BudgetSplit transFrom Nothing
|
||||
, btTo = BudgetSplit transTo Nothing
|
||||
, btValue = dec2Rat v
|
||||
, btName = desc
|
||||
, btDesc = desc
|
||||
}
|
||||
|
||||
insertBudgetTx :: MonadUnliftIO m => BudgetTx -> MappingT m [InsertError]
|
||||
insertBudgetTx BudgetTx {..} = do
|
||||
res <- splitPair (bsAcnt btFrom) (bsAcnt btTo) (bmCur btMeta) btValue
|
||||
unlessLefts_ res $ \(sFrom, sTo) -> lift $ do
|
||||
k <- insert $ TransactionR (bmCommit btMeta) (bmWhen btMeta) btName
|
||||
skFrom <- insertSplit k sFrom
|
||||
bFrom <- insert $ BudgetLabelR skFrom btName
|
||||
forM_ (bsBucket btFrom) $ \b ->
|
||||
insert_ $ IncomeBucketR bFrom b
|
||||
skTo <- insertSplit k sTo
|
||||
bTo <- insert $ BudgetLabelR skTo btName
|
||||
forM_ (bsBucket btTo) $ \b ->
|
||||
insert_ $ ExpenseBucketR bTo b
|
||||
k <- insert $ TransactionR (bmCommit btMeta) (bmWhen btMeta) btDesc
|
||||
insertBudgetLabel name k IncomeBucketR sFrom btFrom
|
||||
insertBudgetLabel name k ExpenseBucketR sTo btTo
|
||||
where
|
||||
name = bmName btMeta
|
||||
|
||||
insertBudgetLabel
|
||||
:: (MonadUnliftIO m, PersistRecordBackend record SqlBackend)
|
||||
=> T.Text
|
||||
-> Key TransactionR
|
||||
-> (Key BudgetLabelR -> a -> record)
|
||||
-> KeySplit
|
||||
-> BudgetSplit a
|
||||
-> SqlPersistT m ()
|
||||
insertBudgetLabel name k bucketType split bs = do
|
||||
sk <- insertSplit k split
|
||||
bk <- insert $ BudgetLabelR sk name
|
||||
forM_ (bsBucket bs) $ insert_ . bucketType bk
|
||||
|
||||
splitPair
|
||||
:: MonadUnliftIO m
|
||||
|
|
|
@ -71,6 +71,7 @@ makeHaskellTypesWith
|
|||
data AccountTree
|
||||
= Placeholder T.Text T.Text [AccountTree]
|
||||
| Account T.Text T.Text
|
||||
deriving (Eq, Generic, Hashable)
|
||||
|
||||
TH.makeBaseFunctor ''AccountTree
|
||||
|
||||
|
@ -110,7 +111,7 @@ type CurID = T.Text
|
|||
|
||||
data Config_ a = Config_
|
||||
{ global :: !Global
|
||||
, budget :: !Budget
|
||||
, budget :: ![Budget]
|
||||
, currencies :: ![Currency]
|
||||
, statements :: ![Statement]
|
||||
, accounts :: !a
|
||||
|
@ -240,6 +241,10 @@ deriving instance Hashable DatePat
|
|||
--------------------------------------------------------------------------------
|
||||
-- Budget (projecting into the future)
|
||||
|
||||
deriving instance Eq Budget
|
||||
|
||||
deriving instance Hashable Budget
|
||||
|
||||
deriving instance Eq Income
|
||||
|
||||
deriving instance Hashable Income
|
||||
|
@ -312,7 +317,7 @@ deriving instance Hashable Transfer
|
|||
data Statement
|
||||
= StmtManual !Manual
|
||||
| StmtImport !Import
|
||||
deriving (Generic, FromDhall)
|
||||
deriving (Eq, Hashable, Generic, FromDhall)
|
||||
|
||||
deriving instance Eq Manual
|
||||
|
||||
|
|
Loading…
Reference in New Issue