ENH use stratified buckets for budget tagging
This commit is contained in:
parent
a6d9f959f1
commit
36c6a56f1b
|
@ -174,45 +174,44 @@ let Import =
|
||||||
|
|
||||||
let Statement = < StmtManual : Manual | StmtImport : Import >
|
let Statement = < StmtManual : Manual | StmtImport : Import >
|
||||||
|
|
||||||
let Bucket = < Fixed | Investment | Savings | Guiltless >
|
let ExpenseBucket = < Fixed | Investment | Savings | Guiltless >
|
||||||
|
|
||||||
let Amount = \(v : Type) -> { amtValue : v, amtDesc : Text }
|
let IncomeBucket = < PreTax | IntraTax | PostTax >
|
||||||
|
|
||||||
let TimeAmount = { taWhen : DatePat, taAmt : Amount Decimal }
|
let Amount = { amtValue : Decimal, amtDesc : Text }
|
||||||
|
|
||||||
|
let TimeAmount = { taWhen : DatePat, taAmt : Amount }
|
||||||
|
|
||||||
let Tax = { taxAcnt : AcntID, taxValue : Decimal }
|
let Tax = { taxAcnt : AcntID, taxValue : Decimal }
|
||||||
|
|
||||||
let Allocation =
|
let Allocation =
|
||||||
\(v : Type) ->
|
{ alloPath : AcntID
|
||||||
{ alloPath : AcntID
|
, alloBucket : ExpenseBucket
|
||||||
, alloBucket : Bucket
|
, alloAmts : List Amount
|
||||||
, alloAmts : List (Amount v)
|
, alloCurrency : CurID
|
||||||
, alloCurrency : CurID
|
}
|
||||||
}
|
|
||||||
|
|
||||||
let PreAllocation = Allocation Decimal
|
|
||||||
|
|
||||||
let PostAllocation = Allocation (Optional Decimal)
|
|
||||||
|
|
||||||
let Income =
|
let Income =
|
||||||
{ incGross : Decimal
|
{ incGross : Decimal
|
||||||
, incCurrency : CurID
|
, incCurrency : CurID
|
||||||
, incWhen : DatePat
|
, incWhen : DatePat
|
||||||
, incAccount : AcntID
|
, incFrom : AcntID
|
||||||
, incPretax : List PreAllocation
|
, incPretax : List Allocation
|
||||||
, incTaxes : List Tax
|
, incTaxes : List Tax
|
||||||
, incPosttax : List PostAllocation
|
, incPosttax : List Allocation
|
||||||
|
, incToBal : AcntID
|
||||||
}
|
}
|
||||||
|
|
||||||
let Expense =
|
let Expense =
|
||||||
{ expFrom : AcntID
|
{ expFrom : AcntID
|
||||||
, expTo : AcntID
|
, expTo : AcntID
|
||||||
, expBucket : Bucket
|
, expBucket : ExpenseBucket
|
||||||
, expAmounts : List TimeAmount
|
, expAmounts : List TimeAmount
|
||||||
, expCurrency : CurID
|
, expCurrency : CurID
|
||||||
}
|
}
|
||||||
|
|
||||||
let Budget = { income : List Income, expenses : List Expense }
|
let Budget =
|
||||||
|
{ income : List Income, expenses : List Expense, manual : List Manual }
|
||||||
|
|
||||||
in { CurID
|
in { CurID
|
||||||
, AcntID
|
, AcntID
|
||||||
|
@ -251,12 +250,11 @@ in { CurID
|
||||||
, Statement
|
, Statement
|
||||||
, Expense
|
, Expense
|
||||||
, Income
|
, Income
|
||||||
, Bucket
|
, IncomeBucket
|
||||||
|
, ExpenseBucket
|
||||||
, Budget
|
, Budget
|
||||||
, Tax
|
, Tax
|
||||||
, Allocation
|
, Allocation
|
||||||
, PreAllocation
|
|
||||||
, PostAllocation
|
|
||||||
, Amount
|
, Amount
|
||||||
, TimeAmount
|
, TimeAmount
|
||||||
}
|
}
|
||||||
|
|
|
@ -4,7 +4,7 @@ let List/map =
|
||||||
|
|
||||||
let T =
|
let T =
|
||||||
./Types.dhall
|
./Types.dhall
|
||||||
sha256:dfbc39a5fe5f4b78b86dc5d4def8de689ff800b6ee506c7a63d573c0be02e976
|
sha256:91a8e19048591cc6b7f72dc62f0d5d7d569864f4736b5649422c746904d03a52
|
||||||
|
|
||||||
let nullSplit =
|
let nullSplit =
|
||||||
\(a : T.SplitAcnt) ->
|
\(a : T.SplitAcnt) ->
|
||||||
|
|
|
@ -51,7 +51,6 @@ TransactionR sql=transactions
|
||||||
commit CommitRId OnDeleteCascade
|
commit CommitRId OnDeleteCascade
|
||||||
date Day
|
date Day
|
||||||
description T.Text
|
description T.Text
|
||||||
bucket T.Text Maybe
|
|
||||||
deriving Show Eq
|
deriving Show Eq
|
||||||
SplitR sql=splits
|
SplitR sql=splits
|
||||||
transaction TransactionRId OnDeleteCascade
|
transaction TransactionRId OnDeleteCascade
|
||||||
|
@ -60,6 +59,15 @@ SplitR sql=splits
|
||||||
memo T.Text
|
memo T.Text
|
||||||
value Rational
|
value Rational
|
||||||
deriving Show Eq
|
deriving Show Eq
|
||||||
|
BudgetLabelR
|
||||||
|
split SplitRId
|
||||||
|
name T.Text
|
||||||
|
ExpenseBucketR
|
||||||
|
budgetLabel BudgetLabelRId
|
||||||
|
bucket T.Text
|
||||||
|
IncomeBucketR
|
||||||
|
budgetLabel BudgetLabelRId
|
||||||
|
bucket T.Text
|
||||||
|]
|
|]
|
||||||
|
|
||||||
type AccountMap = M.Map AcntID (AccountRId, AcntSign)
|
type AccountMap = M.Map AcntID (AccountRId, AcntSign)
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
{-# LANGUAGE GADTs #-}
|
{-# LANGUAGE GADTs #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE TupleSections #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
{-# LANGUAGE NoImplicitPrelude #-}
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
|
|
||||||
module Internal.Insert
|
module Internal.Insert
|
||||||
|
@ -90,6 +90,8 @@ insertBudget :: MonadUnliftIO m => Budget -> MappingT m [InsertError]
|
||||||
insertBudget Budget {income = is, expenses = es} = do
|
insertBudget Budget {income = is, expenses = es} = do
|
||||||
es1 <- mapM insertIncome is
|
es1 <- mapM insertIncome is
|
||||||
es2 <- mapM insertExpense es
|
es2 <- mapM insertExpense es
|
||||||
|
-- es3 <- mapM insertBudgetManual ms
|
||||||
|
-- return $ concat $ es1 ++ es2 ++ es3
|
||||||
return $ concat $ es1 ++ es2
|
return $ concat $ es1 ++ es2
|
||||||
|
|
||||||
-- TODO this hashes twice (not that it really matters)
|
-- TODO this hashes twice (not that it really matters)
|
||||||
|
@ -105,27 +107,86 @@ whenHash t o def f = do
|
||||||
hs <- asks kmNewCommits
|
hs <- asks kmNewCommits
|
||||||
if h `elem` hs then f =<< lift (insert $ CommitR h t) else return def
|
if h `elem` hs then f =<< lift (insert $ CommitR h t) else return def
|
||||||
|
|
||||||
insertIncome :: MonadUnliftIO m => Income -> MappingT m [InsertError]
|
-- TODO allow currency conversions here
|
||||||
insertIncome
|
data BudgetSplit b = BudgetSplit
|
||||||
i@Income
|
{ bsAcnt :: AcntID
|
||||||
{ incCurrency = cur
|
, bsBucket :: Maybe b
|
||||||
, incWhen = dp
|
}
|
||||||
, incAccount = from
|
|
||||||
, incTaxes = taxes
|
|
||||||
} =
|
|
||||||
whenHash CTIncome i [] $ \c ->
|
|
||||||
unlessLeft (balanceIncome i) $ \balanced -> do
|
|
||||||
bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval
|
|
||||||
fmap concat $ forM (expandDatePat bounds dp) $ \day -> do
|
|
||||||
-- TODO why are these separate?
|
|
||||||
nontaxRes <- alloTxs concat (allocationToTx from day) balanced
|
|
||||||
taxRes <- alloTxs (fmap (,Fixed)) (taxToTx from day cur) taxes
|
|
||||||
unlessLefts_ (concatEithers2 nontaxRes taxRes (++)) $ \txs ->
|
|
||||||
lift $ mapM_ (\(t, b) -> insertTxBucket (Just b) c t) txs
|
|
||||||
where
|
|
||||||
alloTxs squish toTx = fmap (fmap squish . concatEithersL) . mapM toTx
|
|
||||||
|
|
||||||
balanceIncome :: Income -> EitherErr [BalAllocation]
|
data BudgetMeta = BudgetMeta
|
||||||
|
{ bmCommit :: Key CommitR
|
||||||
|
, bmWhen :: Day
|
||||||
|
, bmCur :: CurID
|
||||||
|
}
|
||||||
|
|
||||||
|
data BudgetTx = BudgetTx
|
||||||
|
{ btMeta :: BudgetMeta
|
||||||
|
, btFrom :: BudgetSplit IncomeBucket
|
||||||
|
, btTo :: BudgetSplit ExpenseBucket
|
||||||
|
, btValue :: Rational
|
||||||
|
, btDesc :: T.Text
|
||||||
|
}
|
||||||
|
|
||||||
|
insertIncome :: MonadUnliftIO m => Income -> MappingT m [InsertError]
|
||||||
|
insertIncome i@Income {..} =
|
||||||
|
whenHash CTIncome i [] $ \c ->
|
||||||
|
unlessLeft (balanceIncome i) $ \balance ->
|
||||||
|
fmap concat $ withDates incWhen $ \day -> do
|
||||||
|
let meta = BudgetMeta c day incCurrency
|
||||||
|
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 =
|
||||||
|
BudgetTx
|
||||||
|
{ btMeta = meta
|
||||||
|
, btFrom = BudgetSplit incFrom $ Just PostTax
|
||||||
|
, btTo = BudgetSplit incToBal Nothing
|
||||||
|
, btValue = balance
|
||||||
|
, btDesc = "balance after deductions"
|
||||||
|
}
|
||||||
|
fmap concat $ mapM insertBudgetTx $ bal : (pre ++ tax ++ post)
|
||||||
|
|
||||||
|
fromAllo
|
||||||
|
:: BudgetMeta
|
||||||
|
-> AcntID
|
||||||
|
-> Maybe IncomeBucket
|
||||||
|
-> Allocation
|
||||||
|
-> [BudgetTx]
|
||||||
|
fromAllo meta from ib Allocation {..} = fmap (toBT alloPath) alloAmts
|
||||||
|
where
|
||||||
|
toBT to (Amount desc v) =
|
||||||
|
BudgetTx
|
||||||
|
{ btFrom = BudgetSplit from ib
|
||||||
|
, btTo = BudgetSplit to $ Just alloBucket
|
||||||
|
, btValue = dec2Rat v
|
||||||
|
, btDesc = desc
|
||||||
|
, btMeta = meta
|
||||||
|
}
|
||||||
|
|
||||||
|
fromTax :: BudgetMeta -> AcntID -> Tax -> BudgetTx
|
||||||
|
fromTax meta from Tax {taxAcnt = to, taxValue = v} =
|
||||||
|
BudgetTx
|
||||||
|
{ btFrom = BudgetSplit from (Just IntraTax)
|
||||||
|
, btTo = BudgetSplit to (Just Fixed)
|
||||||
|
, btValue = dec2Rat v
|
||||||
|
, btDesc = ""
|
||||||
|
, btMeta = meta
|
||||||
|
}
|
||||||
|
|
||||||
|
withDates
|
||||||
|
:: MonadUnliftIO m
|
||||||
|
=> DatePat
|
||||||
|
-> (Day -> MappingT m a)
|
||||||
|
-> MappingT m [a]
|
||||||
|
withDates dp f = do
|
||||||
|
bounds <- askBounds
|
||||||
|
mapM f (expandDatePat bounds dp)
|
||||||
|
|
||||||
|
askBounds :: MonadUnliftIO m => MappingT m Bounds
|
||||||
|
askBounds = (liftIO . resolveBounds) =<< asks kmBudgetInterval
|
||||||
|
|
||||||
|
balanceIncome :: Income -> EitherErr Rational
|
||||||
balanceIncome
|
balanceIncome
|
||||||
Income
|
Income
|
||||||
{ incGross = g
|
{ incGross = g
|
||||||
|
@ -133,122 +194,33 @@ balanceIncome
|
||||||
, incPretax = pre
|
, incPretax = pre
|
||||||
, incTaxes = tax
|
, incTaxes = tax
|
||||||
, incPosttax = post
|
, incPosttax = post
|
||||||
} = (preRat ++) <$> balancePostTax dp bal postRat
|
}
|
||||||
|
| bal < 0 = Left $ AllocationError undefined dp
|
||||||
|
| otherwise = Right bal
|
||||||
where
|
where
|
||||||
preRat = mapAlloAmts dec2Rat <$> pre
|
bal = dec2Rat g - sum (sumAllocation <$> pre ++ post) - sumTaxes tax
|
||||||
postRat = mapAlloAmts (fmap dec2Rat) <$> post
|
|
||||||
bal = dec2Rat g - (sumAllocations preRat + sumTaxes tax)
|
|
||||||
|
|
||||||
mapAlloAmts :: (a -> b) -> Allocation a -> Allocation b
|
sumAllocation :: Allocation -> Rational
|
||||||
mapAlloAmts f a@Allocation {alloAmts = as} = a {alloAmts = fmap f <$> as}
|
sumAllocation = sum . fmap (dec2Rat . amtValue) . alloAmts
|
||||||
|
|
||||||
sumAllocations :: [BalAllocation] -> Rational
|
|
||||||
sumAllocations = sum . concatMap (fmap amtValue . alloAmts)
|
|
||||||
|
|
||||||
sumTaxes :: [Tax] -> Rational
|
sumTaxes :: [Tax] -> Rational
|
||||||
sumTaxes = sum . fmap (dec2Rat . taxValue)
|
sumTaxes = sum . fmap (dec2Rat . taxValue)
|
||||||
|
|
||||||
balancePostTax :: DatePat -> Rational -> [RawAllocation] -> EitherErr [BalAllocation]
|
|
||||||
balancePostTax dp bal as
|
|
||||||
| null as = err NoAllocations
|
|
||||||
| otherwise = case partitionEithers $ fmap hasVal as of
|
|
||||||
([([empty], nonmissing)], bs) ->
|
|
||||||
let s = bal - sumAllocations (nonmissing : bs)
|
|
||||||
in if s < 0
|
|
||||||
then err ExceededTotal
|
|
||||||
else Right $ mapAmts (empty {amtValue = s} :) nonmissing : bs
|
|
||||||
([], _) -> err MissingBlank
|
|
||||||
_ -> err TooManyBlanks
|
|
||||||
where
|
|
||||||
hasVal a@Allocation {alloAmts = xs} =
|
|
||||||
case partitionEithers $ fmap maybeAmt xs of
|
|
||||||
([], bs) -> Right a {alloAmts = bs}
|
|
||||||
(unbal, bs) -> Left (unbal, a {alloAmts = bs})
|
|
||||||
maybeAmt a@Amount {amtValue = Just v} = Right a {amtValue = v}
|
|
||||||
maybeAmt a = Left a
|
|
||||||
err t = Left $ AllocationError t dp
|
|
||||||
|
|
||||||
-- TODO lens reinvention
|
|
||||||
mapAmts :: ([Amount a] -> [Amount b]) -> Allocation a -> Allocation b
|
|
||||||
mapAmts f a@Allocation {alloAmts = xs} = a {alloAmts = f xs}
|
|
||||||
|
|
||||||
allocationToTx
|
|
||||||
:: MonadUnliftIO m
|
|
||||||
=> AcntID
|
|
||||||
-> Day
|
|
||||||
-> BalAllocation
|
|
||||||
-> MappingT m (EitherErrs [(KeyTx, Bucket)])
|
|
||||||
allocationToTx
|
|
||||||
from
|
|
||||||
day
|
|
||||||
Allocation
|
|
||||||
{ alloPath = to
|
|
||||||
, alloBucket = b
|
|
||||||
, alloCurrency = cur
|
|
||||||
, alloAmts = as
|
|
||||||
} =
|
|
||||||
second (fmap (,b)) . concatEithersL <$> mapM (transferToTx day from to cur) as
|
|
||||||
|
|
||||||
taxToTx
|
|
||||||
:: MonadUnliftIO m
|
|
||||||
=> AcntID
|
|
||||||
-> Day
|
|
||||||
-> T.Text
|
|
||||||
-> Tax
|
|
||||||
-> MappingT m (EitherErrs KeyTx)
|
|
||||||
taxToTx from day cur Tax {taxAcnt = to, taxValue = v} =
|
|
||||||
txPair day from to cur (dec2Rat v) ""
|
|
||||||
|
|
||||||
transferToTx
|
|
||||||
:: MonadUnliftIO m
|
|
||||||
=> Day
|
|
||||||
-> AcntID
|
|
||||||
-> AcntID
|
|
||||||
-> T.Text
|
|
||||||
-> BalAmount
|
|
||||||
-> MappingT m (EitherErrs KeyTx)
|
|
||||||
transferToTx day from to cur Amount {amtValue = v, amtDesc = d} =
|
|
||||||
txPair day from to cur v d
|
|
||||||
|
|
||||||
insertExpense :: MonadUnliftIO m => Expense -> MappingT m [InsertError]
|
insertExpense :: MonadUnliftIO m => Expense -> MappingT m [InsertError]
|
||||||
insertExpense
|
insertExpense e@Expense {..} =
|
||||||
e@Expense
|
fmap (concat . concat) $ whenHash CTExpense e [] $ \key -> do
|
||||||
{ expFrom = from
|
forM expAmounts $ \(TimeAmount amt pat) ->
|
||||||
, expTo = to
|
withDates pat $ \day -> insertBudgetTx $ budgetTx amt day key
|
||||||
, expCurrency = cur
|
where
|
||||||
, expBucket = buc
|
meta d c = BudgetMeta {bmWhen = d, bmCur = expCurrency, bmCommit = c}
|
||||||
, expAmounts = as
|
budgetTx (Amount desc v) d c =
|
||||||
} = do
|
BudgetTx
|
||||||
whenHash CTExpense e [] $ \key -> concat <$> mapM (go key) as
|
{ btMeta = meta d c
|
||||||
where
|
, btFrom = BudgetSplit expFrom Nothing
|
||||||
go key amt = do
|
, btTo = BudgetSplit expTo Nothing
|
||||||
res <- timeAmountToTx from to cur amt
|
, btValue = dec2Rat v
|
||||||
unlessLefts_ res $
|
, btDesc = desc
|
||||||
lift . mapM_ (insertTxBucket (Just buc) key)
|
|
||||||
|
|
||||||
timeAmountToTx
|
|
||||||
:: MonadUnliftIO m
|
|
||||||
=> AcntID
|
|
||||||
-> AcntID
|
|
||||||
-> CurID
|
|
||||||
-> TimeAmount
|
|
||||||
-> MappingT m (EitherErrs [KeyTx])
|
|
||||||
timeAmountToTx
|
|
||||||
from
|
|
||||||
to
|
|
||||||
cur
|
|
||||||
TimeAmount
|
|
||||||
{ taWhen = dp
|
|
||||||
, taAmt =
|
|
||||||
Amount
|
|
||||||
{ amtValue = v
|
|
||||||
, amtDesc = d
|
|
||||||
}
|
}
|
||||||
} = do
|
|
||||||
bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval
|
|
||||||
concatEithersL <$> mapM tx (expandDatePat bounds dp)
|
|
||||||
where
|
|
||||||
tx day = txPair day from to cur (dec2Rat v) d
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- statements
|
-- statements
|
||||||
|
@ -302,7 +274,7 @@ txPair
|
||||||
=> Day
|
=> Day
|
||||||
-> AcntID
|
-> AcntID
|
||||||
-> AcntID
|
-> AcntID
|
||||||
-> T.Text
|
-> CurID
|
||||||
-> Rational
|
-> Rational
|
||||||
-> T.Text
|
-> T.Text
|
||||||
-> MappingT m (EitherErrs KeyTx)
|
-> MappingT m (EitherErrs KeyTx)
|
||||||
|
@ -317,6 +289,35 @@ txPair day from to cur val desc = resolveTx tx
|
||||||
, txSplits = [split from (-val), split to val]
|
, txSplits = [split from (-val), split to val]
|
||||||
}
|
}
|
||||||
|
|
||||||
|
splitPair
|
||||||
|
:: MonadUnliftIO m
|
||||||
|
=> AcntID
|
||||||
|
-> AcntID
|
||||||
|
-> CurID
|
||||||
|
-> Rational
|
||||||
|
-> MappingT m (EitherErrs (KeySplit, KeySplit))
|
||||||
|
splitPair from to cur val = do
|
||||||
|
s1 <- split from (-val)
|
||||||
|
s2 <- split to val
|
||||||
|
return $ concatEithers2 s1 s2 (,)
|
||||||
|
where
|
||||||
|
split a v =
|
||||||
|
resolveSplit $
|
||||||
|
Split
|
||||||
|
{ sAcnt = a
|
||||||
|
, sValue = v
|
||||||
|
, sComment = ""
|
||||||
|
, sCurrency = cur
|
||||||
|
}
|
||||||
|
|
||||||
|
-- tx =
|
||||||
|
-- Tx
|
||||||
|
-- { txDescr = desc
|
||||||
|
-- , txDate = day
|
||||||
|
-- , txTags = []
|
||||||
|
-- , txSplits = [split from (-val), split to val]
|
||||||
|
-- }
|
||||||
|
|
||||||
resolveTx :: MonadUnliftIO m => BalTx -> MappingT m (EitherErrs KeyTx)
|
resolveTx :: MonadUnliftIO m => BalTx -> MappingT m (EitherErrs KeyTx)
|
||||||
resolveTx t@Tx {txSplits = ss} = do
|
resolveTx t@Tx {txSplits = ss} = do
|
||||||
res <- concatEithersL <$> mapM resolveSplit ss
|
res <- concatEithersL <$> mapM resolveSplit ss
|
||||||
|
@ -339,17 +340,55 @@ resolveSplit s@Split {sAcnt = p, sCurrency = c, sValue = v} = do
|
||||||
-- return $ case (aid, cid, sign) of
|
-- return $ case (aid, cid, sign) of
|
||||||
-- _ -> Nothing
|
-- _ -> Nothing
|
||||||
|
|
||||||
insertTxBucket :: MonadUnliftIO m => Maybe Bucket -> Key CommitR -> KeyTx -> SqlPersistT m ()
|
-- insertTax
|
||||||
insertTxBucket b c Tx {txDate = d, txDescr = e, txSplits = ss} = do
|
-- :: MonadUnliftIO m
|
||||||
k <- insert $ TransactionR c d e (fmap (T.pack . show) b)
|
-- => AcntID
|
||||||
|
-- -> CurID
|
||||||
|
-- -> Day
|
||||||
|
-- -> Key CommitR
|
||||||
|
-- -> Tax
|
||||||
|
-- -> MappingT m [InsertError]
|
||||||
|
-- insertTax from cur day commit Tax {taxAcnt = to, taxValue = amnt} =
|
||||||
|
-- insertBudgetValue IntraTax Fixed from to cur commit day "" $ dec2Rat amnt
|
||||||
|
|
||||||
|
-- insertAllocation
|
||||||
|
-- :: MonadUnliftIO m
|
||||||
|
-- => AcntID
|
||||||
|
-- -> CurID
|
||||||
|
-- -> IncomeBucket
|
||||||
|
-- -> Day
|
||||||
|
-- -> Key CommitR
|
||||||
|
-- -> Allocation Decimal
|
||||||
|
-- -> MappingT m [InsertError]
|
||||||
|
-- insertAllocation from cur ib d c (Allocation to xb as _) = concat <$> mapM go as
|
||||||
|
-- where
|
||||||
|
-- go (Amount v desc) = insertBudgetValue ib xb from to cur c d desc $ dec2Rat v
|
||||||
|
|
||||||
|
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) btDesc
|
||||||
|
skFrom <- insertSplit k sFrom
|
||||||
|
bFrom <- insert $ BudgetLabelR skFrom ""
|
||||||
|
forM_ (bsBucket btFrom) $ \b ->
|
||||||
|
insert_ $ IncomeBucketR bFrom $ showT b
|
||||||
|
skTo <- insertSplit k sTo
|
||||||
|
bTo <- insert $ BudgetLabelR skTo ""
|
||||||
|
forM_ (bsBucket btTo) $ \b ->
|
||||||
|
insert_ $ ExpenseBucketR bTo $ showT b
|
||||||
|
|
||||||
|
insertTxBucket :: MonadUnliftIO m => Key CommitR -> KeyTx -> SqlPersistT m ()
|
||||||
|
insertTxBucket c Tx {txDate = d, txDescr = e, txSplits = ss} = do
|
||||||
|
k <- insert $ TransactionR c d e
|
||||||
mapM_ (insertSplit k) ss
|
mapM_ (insertSplit k) ss
|
||||||
|
|
||||||
insertTx :: MonadUnliftIO m => Key CommitR -> KeyTx -> SqlPersistT m ()
|
insertTx :: MonadUnliftIO m => Key CommitR -> KeyTx -> SqlPersistT m ()
|
||||||
insertTx = insertTxBucket Nothing
|
insertTx = insertTxBucket
|
||||||
|
|
||||||
insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m ()
|
insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m (Key SplitR)
|
||||||
insertSplit t Split {sAcnt = aid, sCurrency = cid, sValue = v, sComment = c} = do
|
insertSplit t Split {sAcnt = aid, sCurrency = cid, sValue = v, sComment = c} = do
|
||||||
insert_ $ SplitR t cid aid c v
|
insert $ SplitR t cid aid c v
|
||||||
|
|
||||||
lookupAccount :: MonadUnliftIO m => AcntID -> MappingT m (EitherErr (Key AccountR, AcntSign))
|
lookupAccount :: MonadUnliftIO m => AcntID -> MappingT m (EitherErr (Key AccountR, AcntSign))
|
||||||
lookupAccount p = lookupErr (DBKey AcntField) p <$> asks kmAccount
|
lookupAccount p = lookupErr (DBKey AcntField) p <$> asks kmAccount
|
||||||
|
|
|
@ -24,12 +24,11 @@ import Dhall.TH
|
||||||
import Language.Haskell.TH.Syntax (Lift)
|
import Language.Haskell.TH.Syntax (Lift)
|
||||||
import RIO
|
import RIO
|
||||||
import qualified RIO.Map as M
|
import qualified RIO.Map as M
|
||||||
-- import RIO.State
|
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
import RIO.Time
|
import RIO.Time
|
||||||
|
|
||||||
-------------------------------------------------------------------------------
|
-------------------------------------------------------------------------------
|
||||||
-- YAML CONFIG
|
-- DHALL CONFIG
|
||||||
-------------------------------------------------------------------------------
|
-------------------------------------------------------------------------------
|
||||||
|
|
||||||
makeHaskellTypesWith
|
makeHaskellTypesWith
|
||||||
|
@ -43,7 +42,8 @@ makeHaskellTypesWith
|
||||||
, MultipleConstructors "MatchYMD" "(./dhall/Types.dhall).MatchYMD"
|
, MultipleConstructors "MatchYMD" "(./dhall/Types.dhall).MatchYMD"
|
||||||
, MultipleConstructors "MatchDate" "(./dhall/Types.dhall).MatchDate"
|
, MultipleConstructors "MatchDate" "(./dhall/Types.dhall).MatchDate"
|
||||||
, MultipleConstructors "SplitNum" "(./dhall/Types.dhall).SplitNum"
|
, MultipleConstructors "SplitNum" "(./dhall/Types.dhall).SplitNum"
|
||||||
, MultipleConstructors "Bucket" "(./dhall/Types.dhall).Bucket"
|
, MultipleConstructors "ExpenseBucket" "(./dhall/Types.dhall).ExpenseBucket"
|
||||||
|
, MultipleConstructors "IncomeBucket" "(./dhall/Types.dhall).IncomeBucket"
|
||||||
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
|
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
|
||||||
, SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
|
, SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
|
||||||
, SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
|
, SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
|
||||||
|
@ -57,6 +57,12 @@ makeHaskellTypesWith
|
||||||
, SingleConstructor "MatchVal" "MatchVal" "(./dhall/Types.dhall).MatchVal.Type"
|
, SingleConstructor "MatchVal" "MatchVal" "(./dhall/Types.dhall).MatchVal.Type"
|
||||||
, SingleConstructor "Manual" "Manual" "(./dhall/Types.dhall).Manual"
|
, SingleConstructor "Manual" "Manual" "(./dhall/Types.dhall).Manual"
|
||||||
, SingleConstructor "Tax" "Tax" "(./dhall/Types.dhall).Tax"
|
, SingleConstructor "Tax" "Tax" "(./dhall/Types.dhall).Tax"
|
||||||
|
, SingleConstructor "Amount" "Amount" "(./dhall/Types.dhall).Amount"
|
||||||
|
, SingleConstructor "TimeAmount" "TimeAmount" "(./dhall/Types.dhall).TimeAmount"
|
||||||
|
, SingleConstructor "Allocation" "Allocation" "(./dhall/Types.dhall).Allocation"
|
||||||
|
, SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income"
|
||||||
|
, SingleConstructor "Expense" "Expense" "(./dhall/Types.dhall).Expense"
|
||||||
|
, SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget"
|
||||||
]
|
]
|
||||||
|
|
||||||
-------------------------------------------------------------------------------
|
-------------------------------------------------------------------------------
|
||||||
|
@ -216,61 +222,41 @@ deriving instance Hashable DatePat
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Budget (projecting into the future)
|
-- Budget (projecting into the future)
|
||||||
|
|
||||||
data Income = Income
|
deriving instance Eq Income
|
||||||
{ incGross :: !Decimal
|
|
||||||
, incCurrency :: !CurID
|
|
||||||
, incWhen :: !DatePat
|
|
||||||
, incAccount :: !AcntID
|
|
||||||
, incPretax :: ![Allocation Decimal]
|
|
||||||
, incTaxes :: ![Tax]
|
|
||||||
, incPosttax :: ![Allocation (Maybe Decimal)]
|
|
||||||
}
|
|
||||||
deriving (Eq, Hashable, Generic, FromDhall)
|
|
||||||
|
|
||||||
data Budget = Budget
|
deriving instance Hashable Income
|
||||||
{ income :: ![Income]
|
|
||||||
, expenses :: ![Expense]
|
|
||||||
}
|
|
||||||
deriving (Generic, FromDhall)
|
|
||||||
|
|
||||||
deriving instance Eq Tax
|
deriving instance Eq Tax
|
||||||
|
|
||||||
deriving instance Hashable Tax
|
deriving instance Hashable Tax
|
||||||
|
|
||||||
data Amount v = Amount
|
deriving instance Eq Amount
|
||||||
{ amtValue :: !v
|
|
||||||
, amtDesc :: !T.Text
|
|
||||||
}
|
|
||||||
deriving (Functor, Foldable, Traversable, Eq, Hashable, Generic, FromDhall)
|
|
||||||
|
|
||||||
data Allocation v = Allocation
|
deriving instance Hashable Amount
|
||||||
{ alloPath :: !AcntID
|
|
||||||
, alloBucket :: !Bucket
|
|
||||||
, alloAmts :: ![Amount v]
|
|
||||||
, alloCurrency :: !CurID
|
|
||||||
}
|
|
||||||
deriving (Eq, Hashable, Generic, FromDhall)
|
|
||||||
|
|
||||||
deriving instance Eq Bucket
|
deriving instance Eq Allocation
|
||||||
|
|
||||||
deriving instance Hashable Bucket
|
deriving instance Hashable Allocation
|
||||||
|
|
||||||
deriving instance Show Bucket
|
deriving instance Eq IncomeBucket
|
||||||
|
|
||||||
data TimeAmount = TimeAmount
|
deriving instance Hashable IncomeBucket
|
||||||
{ taWhen :: !DatePat
|
|
||||||
, taAmt :: Amount Decimal
|
|
||||||
}
|
|
||||||
deriving (Eq, Hashable, Generic, FromDhall)
|
|
||||||
|
|
||||||
data Expense = Expense
|
deriving instance Show IncomeBucket
|
||||||
{ expFrom :: !AcntID
|
|
||||||
, expTo :: !AcntID
|
deriving instance Eq ExpenseBucket
|
||||||
, expBucket :: !Bucket
|
|
||||||
, expAmounts :: ![TimeAmount]
|
deriving instance Hashable ExpenseBucket
|
||||||
, expCurrency :: !CurID
|
|
||||||
}
|
deriving instance Show ExpenseBucket
|
||||||
deriving (Eq, Hashable, Generic, FromDhall)
|
|
||||||
|
deriving instance Eq TimeAmount
|
||||||
|
|
||||||
|
deriving instance Hashable TimeAmount
|
||||||
|
|
||||||
|
deriving instance Eq Expense
|
||||||
|
|
||||||
|
deriving instance Hashable Expense
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Statements (data from the past)
|
-- Statements (data from the past)
|
||||||
|
@ -502,14 +488,6 @@ accountSign IncomeT = Credit
|
||||||
accountSign LiabilityT = Credit
|
accountSign LiabilityT = Credit
|
||||||
accountSign EquityT = Credit
|
accountSign EquityT = Credit
|
||||||
|
|
||||||
type RawAmount = Amount (Maybe Rational)
|
|
||||||
|
|
||||||
type BalAmount = Amount Rational
|
|
||||||
|
|
||||||
type RawAllocation = Allocation (Maybe Rational)
|
|
||||||
|
|
||||||
type BalAllocation = Allocation Rational
|
|
||||||
|
|
||||||
type RawSplit = Split AcntID (Maybe Rational) CurID
|
type RawSplit = Split AcntID (Maybe Rational) CurID
|
||||||
|
|
||||||
type BalSplit = Split AcntID Rational CurID
|
type BalSplit = Split AcntID Rational CurID
|
||||||
|
|
Loading…
Reference in New Issue