ENH update types and use deferred allocation math
This commit is contained in:
parent
c2c30caf69
commit
4098e72060
File diff suppressed because it is too large
Load Diff
|
|
@ -119,21 +119,20 @@ withDates dp f = do
|
|||
|
||||
insertBudget :: MonadFinance m => Budget -> SqlPersistT m [InsertError]
|
||||
insertBudget
|
||||
b@( Budget
|
||||
{ budgetLabel
|
||||
, incomes
|
||||
, transfers
|
||||
, shadowTransfers
|
||||
, pretax
|
||||
, tax
|
||||
, posttax
|
||||
}
|
||||
) =
|
||||
b@Budget
|
||||
{ budgetLabel
|
||||
, incomes
|
||||
, transfers
|
||||
, shadowTransfers
|
||||
, pretax
|
||||
, tax
|
||||
, posttax
|
||||
} =
|
||||
whenHash CTBudget b [] $ \key -> do
|
||||
unlessLefts intAllos $ \intAllos_ -> do
|
||||
res1 <- mapM (insertIncome key budgetLabel intAllos_) incomes
|
||||
res2 <- expandTransfers key budgetLabel transfers
|
||||
unlessLefts (concatEithers2 (fmap concat $ concatEithersL res1) res2 (++)) $
|
||||
unlessLefts (concatEithers2 (concat <$> concatEithersL res1) res2 (++)) $
|
||||
\txs -> do
|
||||
unlessLefts (addShadowTransfers shadowTransfers txs) $ \shadow -> do
|
||||
let bals = balanceTransfers $ txs ++ shadow
|
||||
|
|
@ -146,117 +145,120 @@ insertBudget
|
|||
in concatEithers3 pre_ tax_ post_ (,,)
|
||||
sortAllos = concatEithersL . fmap sortAllo
|
||||
|
||||
type BoundAllocation = Allocation_ (TimeAmount (Day, Day))
|
||||
type BoundAllocation = Allocation (Day, Day)
|
||||
|
||||
type IntAllocations = ([BoundAllocation], [BoundAllocation], [BoundAllocation])
|
||||
type IntAllocations =
|
||||
( [BoundAllocation PretaxValue]
|
||||
, [BoundAllocation TaxValue]
|
||||
, [BoundAllocation PosttaxValue]
|
||||
)
|
||||
|
||||
-- TODO this should actually error if there is no ultimate end date
|
||||
sortAllo :: IntervalAllocation -> EitherErrs BoundAllocation
|
||||
sortAllo a@Allocation_ {alloAmts = as} = do
|
||||
bs <- fmap reverse <$> foldBounds (Right []) $ L.sortOn taWhen as
|
||||
return $ a {alloAmts = L.sort bs}
|
||||
-- TODO this should actually error if there is no ultimate end date?
|
||||
sortAllo :: MultiAllocation v -> EitherErrs (BoundAllocation v)
|
||||
sortAllo a@Allocation {alloAmts = as} = do
|
||||
bs <- foldBounds (Right []) $ L.sortOn amtWhen as
|
||||
return $ a {alloAmts = reverse bs}
|
||||
where
|
||||
foldBounds acc [] = acc
|
||||
foldBounds acc (x : xs) =
|
||||
let res = fmap (fmap expandBounds) $ case xs of
|
||||
[] -> mapM resolveBounds x
|
||||
(y : _) ->
|
||||
let end = intStart $ taWhen y
|
||||
in mapM (resolveBounds_ end) x
|
||||
in foldBounds (concatEithers2 (plural res) acc (:)) xs
|
||||
let res = case xs of
|
||||
[] -> resolveBounds $ amtWhen x
|
||||
(y : _) -> resolveBounds_ (intStart $ amtWhen y) $ amtWhen x
|
||||
concatRes bs acc' = x {amtWhen = expandBounds bs} : acc'
|
||||
in foldBounds (concatEithers2 (plural res) acc concatRes) xs
|
||||
|
||||
-- TODO this is going to be O(n*m), which might be a problem?
|
||||
addShadowTransfers :: [ShadowTransfer] -> [BudgetTxType] -> EitherErrs [BudgetTxType]
|
||||
addShadowTransfers
|
||||
:: [ShadowTransfer]
|
||||
-> [UnbalancedTransfer]
|
||||
-> EitherErrs [UnbalancedTransfer]
|
||||
addShadowTransfers ms txs =
|
||||
fmap catMaybes $
|
||||
concatEitherL $
|
||||
fmap (uncurry fromShadow) $
|
||||
[(t, m) | t <- txs, m <- ms]
|
||||
|
||||
fromShadow :: BudgetTxType -> ShadowTransfer -> EitherErr (Maybe BudgetTxType)
|
||||
fromShadow tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio} = do
|
||||
fromShadow
|
||||
:: UnbalancedTransfer
|
||||
-> ShadowTransfer
|
||||
-> EitherErr (Maybe UnbalancedTransfer)
|
||||
fromShadow tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do
|
||||
res <- shadowMatches (stMatch t) tx
|
||||
return $
|
||||
if not res
|
||||
then Nothing
|
||||
else
|
||||
Just $
|
||||
BudgetTxType
|
||||
{ bttTx =
|
||||
-- TODO does this actually share the same metadata as the "parent" tx?
|
||||
BudgetTx
|
||||
{ btMeta = btMeta $ bttTx tx
|
||||
, btWhen = btWhen $ bttTx tx
|
||||
, btFrom = stFrom
|
||||
, btTo = stTo
|
||||
, btValue = dec2Rat stRatio * (btValue $ bttTx tx)
|
||||
, btDesc = stDesc
|
||||
}
|
||||
, bttType = FixedAmt
|
||||
-- TODO does this actually share the same metadata as the "parent" tx?
|
||||
FlatTransfer
|
||||
{ cbtMeta = cbtMeta tx
|
||||
, cbtWhen = cbtWhen tx
|
||||
, cbtCur = stCurrency
|
||||
, cbtFrom = stFrom
|
||||
, cbtTo = stTo
|
||||
, cbtValue = UnbalancedValue stType $ dec2Rat stRatio * cvValue (cbtValue tx)
|
||||
, cbtDesc = stDesc
|
||||
}
|
||||
|
||||
shadowMatches :: ShadowMatch -> BudgetTxType -> EitherErr Bool
|
||||
shadowMatches ShadowMatch {smFrom, smTo, smDate, smVal} tx = do
|
||||
-- TODO what does the amount do for each of the different types?
|
||||
valRes <- valMatches smVal (btValue tx_)
|
||||
shadowMatches :: TransferMatcher -> UnbalancedTransfer -> EitherErr Bool
|
||||
shadowMatches TransferMatcher {smFrom, smTo, smDate, smVal} tx = do
|
||||
valRes <- valMatches smVal $ cvValue $ cbtValue tx
|
||||
return $
|
||||
memberMaybe (taAcnt $ btFrom tx_) smFrom
|
||||
&& memberMaybe (taAcnt $ btTo tx_) smTo
|
||||
&& maybe True (`dateMatches` (btWhen tx_)) smDate
|
||||
memberMaybe (taAcnt $ cbtFrom tx) smFrom
|
||||
&& memberMaybe (taAcnt $ cbtTo tx) smTo
|
||||
&& maybe True (`dateMatches` cbtWhen tx) smDate
|
||||
&& valRes
|
||||
where
|
||||
tx_ = bttTx tx
|
||||
memberMaybe x AcntSet {asList, asInclude} =
|
||||
(if asInclude then id else not) $ x `elem` asList
|
||||
|
||||
balanceTransfers :: [BudgetTxType] -> [BudgetTx]
|
||||
balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer]
|
||||
balanceTransfers ts =
|
||||
snd $ L.mapAccumR go initBals $ reverse $ L.sortOn (btWhen . bttTx) ts
|
||||
snd $ L.mapAccumR go M.empty $ reverse $ L.sortOn cbtWhen ts
|
||||
where
|
||||
initBals =
|
||||
M.fromList $
|
||||
fmap (,0) $
|
||||
L.nub $
|
||||
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 =
|
||||
let tx = bttTx btt
|
||||
from = btFrom tx
|
||||
to = btTo tx
|
||||
bal = lookupBal to bals
|
||||
x = amtToMove bal (bttType btt) (btValue tx)
|
||||
in (updateBal x to $ updateBal (-x) from bals, tx {btValue = x})
|
||||
go bals f@FlatTransfer {cbtFrom, cbtTo, cbtValue = UnbalancedValue {cvValue, cvType}} =
|
||||
let (bals', v) = mapAdd cbtTo x $ mapAdd_ cbtFrom (-x) bals
|
||||
x = amtToMove v cvType cvValue
|
||||
in (bals', f {cbtValue = 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
|
||||
amtToMove _ BTFixed x = x
|
||||
amtToMove bal BTPercent x = -(x / 100 * bal)
|
||||
amtToMove bal BTTarget x = x - bal
|
||||
|
||||
mapAdd_ :: (Ord k, Num v) => k -> v -> M.Map k v -> M.Map k v
|
||||
mapAdd_ k v m = fst $ mapAdd k v m
|
||||
|
||||
mapAdd :: (Ord k, Num v) => k -> v -> M.Map k v -> (M.Map k v, v)
|
||||
mapAdd k v m = (new, M.findWithDefault (error "this should not happen") k new)
|
||||
where
|
||||
new = M.alter (maybe (Just v) (Just . (+ v))) k m
|
||||
|
||||
data BudgetMeta = BudgetMeta
|
||||
{ bmCommit :: !CommitRId
|
||||
, bmCur :: !BudgetCurrency
|
||||
, bmName :: !T.Text
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data BudgetTx = BudgetTx
|
||||
{ btMeta :: !BudgetMeta
|
||||
, btWhen :: !Day
|
||||
, btFrom :: !TaggedAcnt
|
||||
, btTo :: !TaggedAcnt
|
||||
, btValue :: !Rational
|
||||
, btDesc :: !T.Text
|
||||
data FlatTransfer v = FlatTransfer
|
||||
{ cbtFrom :: !TaggedAcnt
|
||||
, cbtTo :: !TaggedAcnt
|
||||
, cbtValue :: !v
|
||||
, cbtWhen :: !Day
|
||||
, cbtDesc :: !T.Text
|
||||
, cbtMeta :: !BudgetMeta
|
||||
, cbtCur :: !BudgetCurrency
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data BudgetTxType = BudgetTxType
|
||||
{ bttType :: !AmountType
|
||||
, bttTx :: !BudgetTx
|
||||
data UnbalancedValue = UnbalancedValue
|
||||
{ cvType :: !BudgetTransferType
|
||||
, cvValue :: !Rational
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
type UnbalancedTransfer = FlatTransfer UnbalancedValue
|
||||
|
||||
type BalancedTransfer = FlatTransfer Rational
|
||||
|
||||
insertIncome
|
||||
:: MonadFinance m
|
||||
|
|
@ -264,179 +266,206 @@ insertIncome
|
|||
-> T.Text
|
||||
-> IntAllocations
|
||||
-> Income
|
||||
-> SqlPersistT m (EitherErrs [BudgetTxType])
|
||||
-> SqlPersistT m (EitherErrs [UnbalancedTransfer])
|
||||
insertIncome
|
||||
key
|
||||
name
|
||||
(intPre, intTax, intPost)
|
||||
i@Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal} = do
|
||||
let meta = BudgetMeta key (NoX incCurrency) name
|
||||
let balRes = balanceIncome i
|
||||
Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal, incGross} = do
|
||||
-- TODO check that the other accounts are not income somewhere here
|
||||
fromRes <- lift $ checkAcntType IncomeT $ taAcnt incFrom
|
||||
case concatEither2 balRes fromRes (,) of
|
||||
Left es -> return $ Left es
|
||||
-- TODO this hole seems sloppy...
|
||||
Right (balance, _) ->
|
||||
fmap (fmap (concat . concat)) $
|
||||
-- TODO this will scan the interval allocations fully each time
|
||||
-- iteration which is a total waste, but the fix requires turning this
|
||||
-- loop into a fold which I don't feel like doing now :(
|
||||
withDates incWhen $ \day -> do
|
||||
let fromAllos = fmap concat . mapM (lift . fromAllo day meta incFrom)
|
||||
pre <- fromAllos $ incPretax ++ mapMaybe (selectAllos day) intPre
|
||||
-- TODO ensure these are all expense accounts
|
||||
tax <- fromAllos $ incTaxes ++ mapMaybe (selectAllos day) intTax
|
||||
post <- fromAllos $ incPosttax ++ mapMaybe (selectAllos day) intPost
|
||||
let bal =
|
||||
BudgetTxType
|
||||
{ bttTx =
|
||||
BudgetTx
|
||||
{ btMeta = meta
|
||||
, btWhen = day
|
||||
, btFrom = incFrom
|
||||
, btTo = incToBal
|
||||
, btValue = balance
|
||||
, btDesc = "balance after deductions"
|
||||
}
|
||||
, bttType = FixedAmt
|
||||
}
|
||||
return $ concatEithersL [Right [bal], Right tax, Right pre, Right post]
|
||||
case fromRes of
|
||||
Left e -> return $ Left [e]
|
||||
-- TODO this will scan the interval allocations fully each time
|
||||
-- iteration which is a total waste, but the fix requires turning this
|
||||
-- loop into a fold which I don't feel like doing now :(
|
||||
Right _ -> fmap concat <$> withDates incWhen (return . allocate)
|
||||
where
|
||||
meta = BudgetMeta key name
|
||||
gross = dec2Rat incGross
|
||||
flatPre = concatMap flattenAllo incPretax
|
||||
flatTax = concatMap flattenAllo incTaxes
|
||||
flatPost = concatMap flattenAllo incPosttax
|
||||
sumAllos = sum . fmap faValue
|
||||
-- TODO ensure these are all the "correct" accounts
|
||||
allocate day =
|
||||
let (preDeductions, pre) =
|
||||
allocatePre gross $
|
||||
flatPre ++ concatMap (selectAllos day) intPre
|
||||
tax =
|
||||
allocateTax gross preDeductions $
|
||||
flatTax ++ concatMap (selectAllos day) intTax
|
||||
aftertaxGross = sumAllos $ tax ++ pre
|
||||
post =
|
||||
allocatePost aftertaxGross $
|
||||
flatPost ++ concatMap (selectAllos day) intPost
|
||||
balance = aftertaxGross - sumAllos post
|
||||
bal =
|
||||
FlatTransfer
|
||||
{ cbtMeta = meta
|
||||
, cbtWhen = day
|
||||
, cbtFrom = incFrom
|
||||
, cbtCur = NoX incCurrency
|
||||
, cbtTo = incToBal
|
||||
, cbtValue = UnbalancedValue BTFixed balance
|
||||
, cbtDesc = "balance after deductions"
|
||||
}
|
||||
in if balance < 0
|
||||
then Left [IncomeError day name balance]
|
||||
else Right $ bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post)
|
||||
|
||||
-- ASSUME allocations are sorted
|
||||
selectAllos :: Day -> BoundAllocation -> Maybe Allocation
|
||||
selectAllos day a@Allocation_ {alloAmts = as} = case select [] as of
|
||||
[] -> Nothing
|
||||
xs -> Just $ a {alloAmts = xs}
|
||||
allocatePre
|
||||
:: Rational
|
||||
-> [FlatAllocation PretaxValue]
|
||||
-> (M.Map T.Text Rational, [FlatAllocation Rational])
|
||||
allocatePre gross = L.mapAccumR go M.empty
|
||||
where
|
||||
select acc [] = acc
|
||||
select acc (x : xs)
|
||||
| day < fst (taWhen x) = select acc xs
|
||||
| inBounds (taWhen x) day = select (taAmt x : acc) xs
|
||||
| otherwise = acc
|
||||
go m f@FlatAllocation {faValue} =
|
||||
let c = preCategory faValue
|
||||
p = dec2Rat $ preValue faValue
|
||||
v = if prePercent faValue then p * gross else p
|
||||
in (mapAdd_ c v m, f {faValue = v})
|
||||
|
||||
fromAllo
|
||||
:: MonadFinance m
|
||||
=> Day
|
||||
-> BudgetMeta
|
||||
allo2Trans
|
||||
:: BudgetMeta
|
||||
-> Day
|
||||
-> TaggedAcnt
|
||||
-> Allocation
|
||||
-> m [BudgetTxType]
|
||||
fromAllo day meta from Allocation_ {alloTo, alloAmts} = do
|
||||
-- TODO this is going to be repeated a zillion times (might matter)
|
||||
-- res <- expandTarget alloPath
|
||||
return $ fmap toBT alloAmts
|
||||
-> FlatAllocation Rational
|
||||
-> UnbalancedTransfer
|
||||
allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} =
|
||||
FlatTransfer
|
||||
{ cbtMeta = meta
|
||||
, cbtWhen = day
|
||||
, cbtFrom = from
|
||||
, cbtCur = faCur
|
||||
, cbtTo = faTo
|
||||
, cbtValue = UnbalancedValue BTFixed faValue
|
||||
, cbtDesc = faDesc
|
||||
}
|
||||
|
||||
allocateTax
|
||||
:: Rational
|
||||
-> M.Map T.Text Rational
|
||||
-> [FlatAllocation TaxValue]
|
||||
-> [FlatAllocation Rational]
|
||||
allocateTax gross deds = fmap (fmap go)
|
||||
where
|
||||
toBT (Amount {amtDesc = desc, amtValue = v}) =
|
||||
BudgetTxType
|
||||
{ bttTx =
|
||||
BudgetTx
|
||||
{ btFrom = from
|
||||
, btWhen = day
|
||||
, btTo = alloTo
|
||||
, btValue = dec2Rat v
|
||||
, btDesc = desc
|
||||
, btMeta = meta
|
||||
}
|
||||
, bttType = FixedAmt
|
||||
go TaxValue {tvCategories, tvMethod} =
|
||||
let agi = gross - sum (mapMaybe (`M.lookup` deds) tvCategories)
|
||||
in case tvMethod of
|
||||
TMPercent p -> dec2Rat p * agi
|
||||
TMBracket TaxProgression {tbsDeductible, tbsBrackets} ->
|
||||
foldBracket (agi - dec2Rat tbsDeductible) tbsBrackets
|
||||
|
||||
allocatePost
|
||||
:: Rational
|
||||
-> [FlatAllocation PosttaxValue]
|
||||
-> [FlatAllocation Rational]
|
||||
allocatePost aftertax = fmap (fmap go)
|
||||
where
|
||||
go PosttaxValue {postValue, postPercent} =
|
||||
let v = dec2Rat postValue in if postPercent then aftertax * v else v
|
||||
|
||||
foldBracket :: Rational -> [TaxBracket] -> Rational
|
||||
foldBracket agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
|
||||
where
|
||||
go TaxBracket {tbLowerLimit, tbPercent} (acc, remain) =
|
||||
let l = dec2Rat tbLowerLimit
|
||||
p = dec2Rat tbPercent
|
||||
in if remain < l then (acc + p * (remain - l), l) else (acc, remain)
|
||||
|
||||
data FlatAllocation v = FlatAllocation
|
||||
{ faValue :: !v
|
||||
, faDesc :: !T.Text
|
||||
, faTo :: !TaggedAcnt
|
||||
, faCur :: !BudgetCurrency
|
||||
}
|
||||
deriving (Functor)
|
||||
|
||||
flattenAllo :: SingleAllocation v -> [FlatAllocation v]
|
||||
flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts
|
||||
where
|
||||
go Amount {amtValue, amtDesc} =
|
||||
FlatAllocation
|
||||
{ faCur = NoX alloCur
|
||||
, faTo = alloTo
|
||||
, faValue = amtValue
|
||||
, faDesc = amtDesc
|
||||
}
|
||||
|
||||
-- -- TODO maybe allow tags here?
|
||||
-- fromTax
|
||||
-- :: MonadFinance m
|
||||
-- => Day
|
||||
-- -> BudgetMeta
|
||||
-- -> AcntID
|
||||
-- -> Tax
|
||||
-- -> m (EitherErr BudgetTxType)
|
||||
-- fromTax day meta from Tax {taxAcnt = to, taxValue = v} = do
|
||||
-- res <- checkAcntType ExpenseT to
|
||||
-- return $ fmap go res
|
||||
-- where
|
||||
-- go to_ =
|
||||
-- BudgetTxType
|
||||
-- { bttTx =
|
||||
-- BudgetTx
|
||||
-- { btFrom = TaggedAcnt from []
|
||||
-- , btWhen = day
|
||||
-- , btTo = TaggedAcnt to_ []
|
||||
-- , btValue = dec2Rat v
|
||||
-- , btDesc = ""
|
||||
-- , btMeta = meta
|
||||
-- }
|
||||
-- , bttType = FixedAmt
|
||||
-- }
|
||||
|
||||
balanceIncome :: Income -> EitherErr Rational
|
||||
balanceIncome
|
||||
Income
|
||||
{ incGross = g
|
||||
, incWhen = dp
|
||||
, incPretax = pre
|
||||
, incTaxes = tax
|
||||
, incPosttax = post
|
||||
}
|
||||
| bal < 0 = Left $ IncomeError dp
|
||||
| otherwise = Right bal
|
||||
where
|
||||
bal = dec2Rat g - sum (sumAllocation <$> pre ++ tax ++ post)
|
||||
|
||||
sumAllocation :: Allocation -> Rational
|
||||
sumAllocation = sum . fmap (dec2Rat . amtValue) . alloAmts
|
||||
|
||||
-- sumTaxes :: [Tax] -> Rational
|
||||
-- sumTaxes = sum . fmap (dec2Rat . taxValue)
|
||||
-- ASSUME allocations are sorted
|
||||
selectAllos :: Day -> BoundAllocation v -> [FlatAllocation v]
|
||||
selectAllos day Allocation {alloAmts, alloCur, alloTo} =
|
||||
fmap go $
|
||||
takeWhile ((`inBounds` day) . amtWhen) $
|
||||
dropWhile ((day <) . fst . amtWhen) alloAmts
|
||||
where
|
||||
go Amount {amtValue, amtDesc} =
|
||||
FlatAllocation
|
||||
{ faCur = NoX alloCur
|
||||
, faTo = alloTo
|
||||
, faValue = amtValue
|
||||
, faDesc = amtDesc
|
||||
}
|
||||
|
||||
expandTransfers
|
||||
:: MonadFinance m
|
||||
=> CommitRId
|
||||
-> T.Text
|
||||
-> [Transfer]
|
||||
-> SqlPersistT m (EitherErrs [BudgetTxType])
|
||||
-> [BudgetTransfer]
|
||||
-> SqlPersistT m (EitherErrs [UnbalancedTransfer])
|
||||
expandTransfers key name ts = do
|
||||
txs <- mapM (expandTransfer key name) ts
|
||||
return $ L.sortOn (btWhen . bttTx) . concat <$> concatEithersL txs
|
||||
return $ L.sortOn cbtWhen . concat <$> concatEithersL txs
|
||||
|
||||
expandTransfer :: MonadFinance m => CommitRId -> T.Text -> Transfer -> SqlPersistT m (EitherErrs [BudgetTxType])
|
||||
expandTransfer
|
||||
:: MonadFinance m
|
||||
=> CommitRId
|
||||
-> T.Text
|
||||
-> BudgetTransfer
|
||||
-> SqlPersistT m (EitherErrs [UnbalancedTransfer])
|
||||
expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} =
|
||||
-- whenHash CTExpense t (Right []) $ \key ->
|
||||
fmap (fmap concat . concatEithersL) $
|
||||
forM transAmounts $ \(TimeAmount {taWhen = pat, taAmt = (Amount {amtDesc = desc, amtValue = v}), taAmtType = atype}) -> do
|
||||
withDates pat $ \day ->
|
||||
let meta =
|
||||
BudgetMeta
|
||||
{ bmCur = transCurrency
|
||||
, bmCommit = key
|
||||
, bmName = name
|
||||
}
|
||||
tx =
|
||||
BudgetTxType
|
||||
{ bttTx =
|
||||
BudgetTx
|
||||
{ btMeta = meta
|
||||
, btWhen = day
|
||||
, btFrom = transFrom
|
||||
, btTo = transTo
|
||||
, btValue = dec2Rat v
|
||||
, btDesc = desc
|
||||
forM transAmounts $
|
||||
\Amount
|
||||
{ amtWhen = pat
|
||||
, amtValue = BudgetTransferValue {btVal = v, btType = y}
|
||||
, amtDesc = desc
|
||||
} ->
|
||||
do
|
||||
withDates pat $ \day ->
|
||||
let meta =
|
||||
BudgetMeta
|
||||
{ bmCommit = key
|
||||
, bmName = name
|
||||
}
|
||||
, bttType = atype
|
||||
}
|
||||
in return $ Right tx
|
||||
tx =
|
||||
FlatTransfer
|
||||
{ cbtMeta = meta
|
||||
, cbtWhen = day
|
||||
, cbtCur = transCurrency
|
||||
, cbtFrom = transFrom
|
||||
, cbtTo = transTo
|
||||
, cbtValue = UnbalancedValue y $ dec2Rat v
|
||||
, cbtDesc = desc
|
||||
}
|
||||
in return $ Right tx
|
||||
|
||||
insertBudgetTx :: MonadFinance m => BudgetTx -> SqlPersistT m [InsertError]
|
||||
insertBudgetTx BudgetTx {btFrom, btTo, btMeta, btValue, btDesc, btWhen} = do
|
||||
res <- lift $ splitPair btFrom btTo (bmCur btMeta) btValue
|
||||
insertBudgetTx :: MonadFinance m => BalancedTransfer -> SqlPersistT m [InsertError]
|
||||
insertBudgetTx FlatTransfer {cbtFrom, cbtTo, cbtMeta, cbtCur, cbtValue, cbtDesc, cbtWhen} = do
|
||||
res <- lift $ splitPair cbtFrom cbtTo cbtCur cbtValue
|
||||
unlessLefts_ res $ \((sFrom, sTo), exchange) -> do
|
||||
insertPair sFrom sTo
|
||||
forM_ exchange $ \(xFrom, xTo) -> insertPair xFrom xTo
|
||||
forM_ exchange $ uncurry insertPair
|
||||
where
|
||||
insertPair from to = do
|
||||
k <- insert $ TransactionR (bmCommit btMeta) btWhen btDesc
|
||||
k <- insert $ TransactionR (bmCommit cbtMeta) cbtWhen cbtDesc
|
||||
insertBudgetLabel k from
|
||||
insertBudgetLabel k to
|
||||
insertBudgetLabel k split = do
|
||||
sk <- insertSplit k split
|
||||
insert_ $ BudgetLabelR sk $ bmName btMeta
|
||||
insert_ $ BudgetLabelR sk $ bmName cbtMeta
|
||||
|
||||
type SplitPair = (KeySplit, KeySplit)
|
||||
|
||||
|
|
@ -448,8 +477,8 @@ splitPair
|
|||
-> Rational
|
||||
-> m (EitherErrs (SplitPair, Maybe SplitPair))
|
||||
splitPair from to cur val = case cur of
|
||||
NoX curid -> fmap (fmap (,Nothing)) $ pair curid from to val
|
||||
X (Exchange {xFromCur, xToCur, xAcnt, xRate}) -> do
|
||||
NoX curid -> fmap (,Nothing) <$> pair curid from to val
|
||||
X Exchange {xFromCur, xToCur, xAcnt, xRate} -> do
|
||||
let middle = TaggedAcnt xAcnt []
|
||||
res1 <- pair xFromCur from middle val
|
||||
res2 <- pair xToCur middle to (val * dec2Rat xRate)
|
||||
|
|
@ -461,7 +490,7 @@ splitPair from to cur val = case cur of
|
|||
return $ concatEithers2 s1 s2 (,)
|
||||
split c TaggedAcnt {taAcnt, taTags} v =
|
||||
resolveSplit $
|
||||
Split
|
||||
Entry
|
||||
{ sAcnt = taAcnt
|
||||
, sValue = v
|
||||
, sComment = ""
|
||||
|
|
@ -493,31 +522,31 @@ checkAcntTypes ts i = (go =<<) <$> lookupAccountType i
|
|||
insertStatements :: MonadFinance m => Config -> SqlPersistT m [InsertError]
|
||||
insertStatements conf = concat <$> mapM insertStatement (statements conf)
|
||||
|
||||
insertStatement :: MonadFinance m => Statement -> SqlPersistT m [InsertError]
|
||||
insertStatement (StmtManual m) = insertManual m
|
||||
insertStatement (StmtImport i) = insertImport i
|
||||
insertStatement :: MonadFinance m => History -> SqlPersistT m [InsertError]
|
||||
insertStatement (HistTransfer m) = insertManual m
|
||||
insertStatement (HistStatement i) = insertImport i
|
||||
|
||||
insertManual :: MonadFinance m => Manual -> SqlPersistT m [InsertError]
|
||||
insertManual :: MonadFinance m => HistTransfer -> SqlPersistT m [InsertError]
|
||||
insertManual
|
||||
m@Manual
|
||||
{ manualDate = dp
|
||||
, manualFrom = from
|
||||
, manualTo = to
|
||||
, manualValue = v
|
||||
, manualCurrency = u
|
||||
, manualDesc = e
|
||||
m@Transfer
|
||||
{ transFrom = from
|
||||
, transTo = to
|
||||
, transCurrency = u
|
||||
, transAmounts = amts
|
||||
} = do
|
||||
whenHash CTManual m [] $ \c -> do
|
||||
bounds <- lift $ askDBState kmStatementInterval
|
||||
-- let days = expandDatePat bounds dp
|
||||
let dayRes = expandDatePat bounds dp
|
||||
unlessLefts dayRes $ \days -> do
|
||||
txRes <- mapM (lift . tx) days
|
||||
unlessLefts_ (concatEithersL txRes) $ mapM_ (insertTx c)
|
||||
where
|
||||
tx day = txPair day from to u (dec2Rat v) e
|
||||
es <- forM amts $ \Amount {amtWhen, amtValue, amtDesc} -> do
|
||||
let v = dec2Rat amtValue
|
||||
let dayRes = expandDatePat bounds amtWhen
|
||||
unlessLefts dayRes $ \days -> do
|
||||
let tx day = txPair day from to u v amtDesc
|
||||
txRes <- mapM (lift . tx) days
|
||||
unlessLefts_ (concatEithersL txRes) $ mapM_ (insertTx c)
|
||||
return $ concat es
|
||||
|
||||
insertImport :: MonadFinance m => Import -> SqlPersistT m [InsertError]
|
||||
insertImport :: MonadFinance m => Statement -> SqlPersistT m [InsertError]
|
||||
insertImport i = whenHash CTImport i [] $ \c -> do
|
||||
-- TODO this isn't efficient, the whole file will be read and maybe no
|
||||
-- transactions will be desired
|
||||
|
|
@ -549,7 +578,7 @@ txPair
|
|||
-> m (EitherErrs KeyTx)
|
||||
txPair day from to cur val desc = resolveTx tx
|
||||
where
|
||||
split a v = Split {sAcnt = a, sValue = v, sComment = "", sCurrency = cur, sTags = []}
|
||||
split a v = Entry {sAcnt = a, sValue = v, sComment = "", sCurrency = cur, sTags = []}
|
||||
tx =
|
||||
Tx
|
||||
{ txDescr = desc
|
||||
|
|
@ -563,7 +592,7 @@ resolveTx t@Tx {txSplits = ss} = do
|
|||
return $ fmap (\kss -> t {txSplits = kss}) res
|
||||
|
||||
resolveSplit :: MonadFinance m => BalSplit -> m (EitherErrs KeySplit)
|
||||
resolveSplit s@Split {sAcnt, sCurrency, sValue, sTags} = do
|
||||
resolveSplit s@Entry {sAcnt, sCurrency, sValue, sTags} = do
|
||||
aid <- lookupAccountKey sAcnt
|
||||
cid <- lookupCurrency sCurrency
|
||||
sign <- lookupAccountSign sAcnt
|
||||
|
|
@ -571,7 +600,7 @@ resolveSplit s@Split {sAcnt, sCurrency, sValue, sTags} = do
|
|||
-- TODO correct sign here?
|
||||
-- TODO lenses would be nice here
|
||||
return $
|
||||
(concatEithers2 (concatEither3 aid cid sign (,,)) $ concatEitherL tags) $
|
||||
concatEithers2 (concatEither3 aid cid sign (,,)) (concatEitherL tags) $
|
||||
\(aid_, cid_, sign_) tags_ ->
|
||||
s
|
||||
{ sAcnt = aid_
|
||||
|
|
@ -586,16 +615,16 @@ insertTx c Tx {txDate = d, txDescr = e, txSplits = ss} = do
|
|||
mapM_ (insertSplit k) ss
|
||||
|
||||
insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m (Key SplitR)
|
||||
insertSplit t Split {sAcnt, sCurrency, sValue, sComment, sTags} = do
|
||||
insertSplit t Entry {sAcnt, sCurrency, sValue, sComment, sTags} = do
|
||||
k <- insert $ SplitR t sCurrency sAcnt sComment sValue
|
||||
mapM_ (insert_ . TagRelationR k) sTags
|
||||
return k
|
||||
|
||||
lookupAccount :: MonadFinance m => AcntID -> m (EitherErr (Key AccountR, AcntSign, AcntType))
|
||||
lookupAccount p = lookupErr (DBKey AcntField) p <$> (askDBState kmAccount)
|
||||
lookupAccount p = lookupErr (DBKey AcntField) p <$> askDBState kmAccount
|
||||
|
||||
lookupAccountKey :: MonadFinance m => AcntID -> m (EitherErr (Key AccountR))
|
||||
lookupAccountKey = (fmap (fmap fstOf3)) . lookupAccount
|
||||
lookupAccountKey = fmap (fmap fstOf3) . lookupAccount
|
||||
|
||||
lookupAccountSign :: MonadFinance m => AcntID -> m (EitherErr AcntSign)
|
||||
lookupAccountSign = fmap (fmap sndOf3) . lookupAccount
|
||||
|
|
@ -604,10 +633,10 @@ 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)
|
||||
lookupCurrency c = lookupErr (DBKey CurField) c <$> askDBState kmCurrency
|
||||
|
||||
lookupTag :: MonadFinance m => TagID -> m (EitherErr (Key TagR))
|
||||
lookupTag c = lookupErr (DBKey TagField) c <$> (askDBState kmTag)
|
||||
lookupTag c = lookupErr (DBKey TagField) c <$> askDBState kmTag
|
||||
|
||||
-- TODO this hashes twice (not that it really matters)
|
||||
whenHash
|
||||
|
|
|
|||
|
|
@ -19,8 +19,8 @@ import qualified RIO.Vector as V
|
|||
|
||||
-- TODO this probably won't scale well (pipes?)
|
||||
|
||||
readImport :: MonadFinance m => Import -> m (EitherErrs [BalTx])
|
||||
readImport Import {..} = do
|
||||
readImport :: MonadFinance m => Statement -> m (EitherErrs [BalTx])
|
||||
readImport Statement {..} = do
|
||||
let ores = plural $ compileOptions impTxOpts
|
||||
let cres = concatEithersL $ compileMatch <$> impMatches
|
||||
case concatEithers2 ores cres (,) of
|
||||
|
|
@ -219,7 +219,7 @@ balanceSplits ss =
|
|||
$ groupByKey
|
||||
$ fmap (\s -> (sCurrency s, s)) ss
|
||||
where
|
||||
hasValue s@(Split {sValue = Just v}) = Right s {sValue = v}
|
||||
hasValue s@Entry {sValue = Just v} = Right s {sValue = v}
|
||||
hasValue s = Left s
|
||||
bal cur rss
|
||||
| length rss < 2 = Left $ BalanceError TooFewSplits cur rss
|
||||
|
|
|
|||
|
|
@ -33,33 +33,38 @@ makeHaskellTypesWith
|
|||
, MultipleConstructors "WeekdayPat" "(./dhall/Types.dhall).WeekdayPat"
|
||||
, MultipleConstructors "MDYPat" "(./dhall/Types.dhall).MDYPat"
|
||||
, MultipleConstructors "DatePat" "(./dhall/Types.dhall).DatePat"
|
||||
, MultipleConstructors "MatchYMD" "(./dhall/Types.dhall).MatchYMD"
|
||||
, MultipleConstructors "MatchDate" "(./dhall/Types.dhall).MatchDate"
|
||||
, MultipleConstructors "SplitNum" "(./dhall/Types.dhall).SplitNum"
|
||||
, MultipleConstructors "AmountType" "(./dhall/Types.dhall).AmountType"
|
||||
, MultipleConstructors "YMDMatcher" "(./dhall/Types.dhall).YMDMatcher"
|
||||
, MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher"
|
||||
, MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter"
|
||||
, MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
|
||||
, MultipleConstructors "BudgetTransferType" "(./dhall/Types.dhall).BudgetTransferType"
|
||||
, MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod"
|
||||
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
|
||||
, SingleConstructor "Tag" "Tag" "(./dhall/Types.dhall).Tag"
|
||||
, SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt"
|
||||
, SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
|
||||
, SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
|
||||
, SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval"
|
||||
, SingleConstructor "Global" "Global" "(./dhall/Types.dhall).Global"
|
||||
, SingleConstructor "TemporalScope" "TemporalScope" "(./dhall/Types.dhall).TemporalScope"
|
||||
, SingleConstructor "RepeatPat" "RepeatPat" "(./dhall/Types.dhall).RepeatPat"
|
||||
, SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type"
|
||||
, SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.Type"
|
||||
, SingleConstructor "Decimal" "D" "(./dhall/Types.dhall).Decimal"
|
||||
, SingleConstructor "MatchVal" "MatchVal" "(./dhall/Types.dhall).MatchVal.Type"
|
||||
, SingleConstructor "Manual" "Manual" "(./dhall/Types.dhall).Manual"
|
||||
, SingleConstructor "ValMatcher" "ValMatcher" "(./dhall/Types.dhall).ValMatcher.Type"
|
||||
, SingleConstructor "Amount" "Amount" "(./dhall/Types.dhall).Amount"
|
||||
, SingleConstructor "TimeAmount" "TimeAmount" "(./dhall/Types.dhall).TimeAmount"
|
||||
, SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt"
|
||||
, SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type"
|
||||
, SingleConstructor "ShadowMatch" "ShadowMatch" "(./dhall/Types.dhall).ShadowMatch.Type"
|
||||
, SingleConstructor "TransferMatcher" "TransferMatcher" "(./dhall/Types.dhall).TransferMatcher.Type"
|
||||
, SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer"
|
||||
, -- , SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income.Type"
|
||||
SingleConstructor "Exchange" "Exchange" "(./dhall/Types.dhall).Exchange"
|
||||
, SingleConstructor "Field" "Field" "(./dhall/Types.dhall).Field"
|
||||
, SingleConstructor "Split" "Split" "(./dhall/Types.dhall).Split"
|
||||
, SingleConstructor "Entry" "Entry" "(./dhall/Types.dhall).Entry"
|
||||
, SingleConstructor "PretaxValue" "PretaxValue" "(./dhall/Types.dhall).PretaxValue"
|
||||
, SingleConstructor "TaxBracket" "TaxBracket" "(./dhall/Types.dhall).TaxBracket"
|
||||
, SingleConstructor "TaxProgression" "TaxProgression" "(./dhall/Types.dhall).TaxProgression"
|
||||
, SingleConstructor "TaxValue" "TaxValue" "(./dhall/Types.dhall).TaxValue"
|
||||
, SingleConstructor "PosttaxValue" "PosttaxValue" "(./dhall/Types.dhall).PosttaxValue"
|
||||
, SingleConstructor "BudgetTransferValue" "BudgetTransferValue" "(./dhall/Types.dhall).BudgetTransferValue"
|
||||
-- , SingleConstructor "ToTx" "ToTx" "(./dhall/Types.dhall).ToTx"
|
||||
-- , SingleConstructor "MatchOther" "MatchOther" "(./dhall/Types.dhall).MatchOther_"
|
||||
-- , SingleConstructor "Match" "Match" "(./dhall/Types.dhall).Match_"
|
||||
|
|
@ -86,21 +91,25 @@ deriveProduct
|
|||
, "Budget"
|
||||
, "Income"
|
||||
, "ShadowTransfer"
|
||||
, "ShadowMatch"
|
||||
, "TransferMatcher"
|
||||
, "AcntSet"
|
||||
, "MatchDate"
|
||||
, "MatchVal"
|
||||
, "MatchYMD"
|
||||
, "DateMatcher"
|
||||
, "ValMatcher"
|
||||
, "YMDMatcher"
|
||||
, "Decimal"
|
||||
, "Transfer"
|
||||
, "BudgetCurrency"
|
||||
, "Manual"
|
||||
, "Exchange"
|
||||
, "Amount"
|
||||
, "AmountType"
|
||||
, "SplitNum"
|
||||
, "Global"
|
||||
, "EntryNumGetter"
|
||||
, "TemporalScope"
|
||||
, "SqlConfig"
|
||||
, "PretaxValue"
|
||||
, "TaxValue"
|
||||
, "TaxBracket"
|
||||
, "TaxProgression"
|
||||
, "TaxMethod"
|
||||
, "PosttaxValue"
|
||||
, "BudgetTransferValue"
|
||||
, "BudgetTransferType"
|
||||
]
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
|
|
@ -168,18 +177,37 @@ deriving instance Ord DatePat
|
|||
|
||||
deriving instance Hashable DatePat
|
||||
|
||||
type BudgetTransfer =
|
||||
Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue
|
||||
|
||||
data Budget = Budget
|
||||
{ budgetLabel :: Text
|
||||
, incomes :: [Income]
|
||||
, pretax :: [IntervalAllocation]
|
||||
, tax :: [IntervalAllocation]
|
||||
, posttax :: [IntervalAllocation]
|
||||
, transfers :: [Transfer]
|
||||
, pretax :: [MultiAllocation PretaxValue]
|
||||
, tax :: [MultiAllocation TaxValue]
|
||||
, posttax :: [MultiAllocation PosttaxValue]
|
||||
, transfers :: [BudgetTransfer]
|
||||
, shadowTransfers :: [ShadowTransfer]
|
||||
}
|
||||
|
||||
deriving instance Hashable PretaxValue
|
||||
|
||||
deriving instance Hashable TaxBracket
|
||||
|
||||
deriving instance Hashable TaxProgression
|
||||
|
||||
deriving instance Hashable TaxMethod
|
||||
|
||||
deriving instance Hashable TaxValue
|
||||
|
||||
deriving instance Hashable PosttaxValue
|
||||
|
||||
deriving instance Hashable Budget
|
||||
|
||||
deriving instance Hashable BudgetTransferValue
|
||||
|
||||
deriving instance Hashable BudgetTransferType
|
||||
|
||||
deriving instance Hashable TaggedAcnt
|
||||
|
||||
deriving instance Ord TaggedAcnt
|
||||
|
|
@ -190,35 +218,49 @@ data Income = Income
|
|||
{ incGross :: Decimal
|
||||
, incCurrency :: CurID
|
||||
, incWhen :: DatePat
|
||||
, incPretax :: [Allocation]
|
||||
, incTaxes :: [Allocation]
|
||||
, incPosttax :: [Allocation]
|
||||
, incPretax :: [SingleAllocation PretaxValue]
|
||||
, incTaxes :: [SingleAllocation TaxValue]
|
||||
, incPosttax :: [SingleAllocation PosttaxValue]
|
||||
, incFrom :: TaggedAcnt
|
||||
, incToBal :: TaggedAcnt
|
||||
}
|
||||
|
||||
deriving instance Hashable Income
|
||||
|
||||
deriving instance Ord Amount
|
||||
deriving instance (Ord w, Ord v) => Ord (Amount w v)
|
||||
|
||||
deriving instance Hashable Amount
|
||||
deriving instance Generic (Amount w v)
|
||||
|
||||
deriving instance (Generic w, Generic v, FromDhall w, FromDhall v) => FromDhall (Amount w v)
|
||||
|
||||
deriving instance (Generic w, Generic v, Hashable w, Hashable v) => Hashable (Amount w v)
|
||||
|
||||
deriving instance (Show w, Show v) => Show (Amount w v)
|
||||
|
||||
deriving instance (Eq w, Eq v) => Eq (Amount w v)
|
||||
|
||||
deriving instance Hashable Exchange
|
||||
|
||||
deriving instance Hashable BudgetCurrency
|
||||
|
||||
data Allocation_ a = Allocation_
|
||||
data Allocation w v = Allocation
|
||||
{ alloTo :: TaggedAcnt
|
||||
, alloAmts :: [a]
|
||||
, alloCur :: BudgetCurrency
|
||||
, alloAmts :: [Amount w v]
|
||||
, alloCur :: CurID
|
||||
}
|
||||
deriving (Eq, Show, Generic, Hashable)
|
||||
|
||||
deriving instance FromDhall a => FromDhall (Allocation_ a)
|
||||
instance Bifunctor Amount where
|
||||
bimap f g a@Amount {amtWhen, amtValue} = a {amtWhen = f amtWhen, amtValue = g amtValue}
|
||||
|
||||
type Allocation = Allocation_ Amount
|
||||
instance Bifunctor Allocation where
|
||||
bimap f g a@Allocation {alloAmts} = a {alloAmts = fmap (bimap f g) alloAmts}
|
||||
|
||||
type IntervalAllocation = Allocation_ IntervalAmount
|
||||
deriving instance (Generic w, Generic v, FromDhall w, FromDhall v) => FromDhall (Allocation w v)
|
||||
|
||||
type MultiAllocation = Allocation Interval
|
||||
|
||||
type SingleAllocation = Allocation ()
|
||||
|
||||
toPersistText :: Show a => a -> PersistValue
|
||||
toPersistText = PersistText . T.pack . show
|
||||
|
|
@ -230,68 +272,38 @@ fromPersistText what (PersistText t) = case readMaybe $ T.unpack t of
|
|||
fromPersistText what x =
|
||||
Left $ T.unwords ["error when deserializing", what, "; got", T.pack (show x)]
|
||||
|
||||
deriving instance Ord AmountType
|
||||
|
||||
deriving instance Hashable AmountType
|
||||
|
||||
-- data TimeAmount a = TimeAmount
|
||||
-- { taWhen :: a
|
||||
-- , taAmt :: Amount
|
||||
-- , taAmtType :: AmountType
|
||||
-- }
|
||||
-- deriving (Show, Eq, Ord, Functor, Generic, FromDhall, Hashable, Foldable, Traversable)
|
||||
|
||||
deriving instance Show a => Show (TimeAmount a)
|
||||
|
||||
deriving instance Eq a => Eq (TimeAmount a)
|
||||
|
||||
deriving instance Ord a => Ord (TimeAmount a)
|
||||
|
||||
deriving instance Functor TimeAmount
|
||||
|
||||
deriving instance Foldable TimeAmount
|
||||
|
||||
deriving instance Traversable TimeAmount
|
||||
|
||||
deriving instance Generic (TimeAmount a)
|
||||
|
||||
deriving instance Hashable a => Hashable (TimeAmount a)
|
||||
|
||||
deriving instance FromDhall a => FromDhall (TimeAmount a)
|
||||
|
||||
type DateAmount = TimeAmount DatePat
|
||||
|
||||
type IntervalAmount = TimeAmount Interval
|
||||
|
||||
deriving instance Ord Interval
|
||||
|
||||
data Transfer = Transfer
|
||||
{ transFrom :: TaggedAcnt
|
||||
, transTo :: TaggedAcnt
|
||||
, transAmounts :: [DateAmount]
|
||||
, transCurrency :: BudgetCurrency
|
||||
data Transfer a c w v = Transfer
|
||||
{ transFrom :: a
|
||||
, transTo :: a
|
||||
, transAmounts :: [Amount w v]
|
||||
, transCurrency :: c
|
||||
}
|
||||
deriving (Eq, Show, Generic, FromDhall)
|
||||
|
||||
deriving instance Hashable Transfer
|
||||
deriving instance
|
||||
(Generic w, Generic v, Hashable a, Hashable c, Hashable w, Hashable v)
|
||||
=> Hashable (Transfer a c w v)
|
||||
|
||||
deriving instance Hashable ShadowTransfer
|
||||
|
||||
deriving instance Hashable AcntSet
|
||||
|
||||
deriving instance Hashable ShadowMatch
|
||||
deriving instance Hashable TransferMatcher
|
||||
|
||||
deriving instance Hashable MatchVal
|
||||
deriving instance Hashable ValMatcher
|
||||
|
||||
deriving instance Hashable MatchYMD
|
||||
deriving instance Hashable YMDMatcher
|
||||
|
||||
deriving instance Hashable MatchDate
|
||||
deriving instance Hashable DateMatcher
|
||||
|
||||
deriving instance Ord Decimal
|
||||
|
||||
deriving instance Hashable Decimal
|
||||
|
||||
-- TODO this just looks silly...but not sure how to simplify it
|
||||
instance Ord MatchYMD where
|
||||
instance Ord YMDMatcher where
|
||||
compare (Y y) (Y y') = compare y y'
|
||||
compare (YM g) (YM g') = compare g g'
|
||||
compare (YMD g) (YMD g') = compare g g'
|
||||
|
|
@ -306,15 +318,13 @@ gregM :: Gregorian -> GregorianM
|
|||
gregM Gregorian {gYear = y, gMonth = m} =
|
||||
GregorianM {gmYear = y, gmMonth = m}
|
||||
|
||||
instance Ord MatchDate where
|
||||
instance Ord DateMatcher where
|
||||
compare (On d) (On d') = compare d d'
|
||||
compare (In d r) (In d' r') = compare d d' <> compare r r'
|
||||
compare (On d) (In d' _) = compare d d' <> LT
|
||||
compare (In d _) (On d') = compare d d' <> GT
|
||||
|
||||
deriving instance Hashable SplitNum
|
||||
|
||||
deriving instance Hashable Manual
|
||||
deriving instance Hashable EntryNumGetter
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- top level type with fixed account tree to unroll the recursion in the dhall
|
||||
|
|
@ -347,10 +357,10 @@ deriving instance FromDhall AccountRootF
|
|||
type AccountRoot = AccountRoot_ AccountTree
|
||||
|
||||
data Config_ a = Config_
|
||||
{ global :: !Global
|
||||
{ global :: !TemporalScope
|
||||
, budget :: ![Budget]
|
||||
, currencies :: ![Currency]
|
||||
, statements :: ![Statement]
|
||||
, statements :: ![History]
|
||||
, accounts :: !a
|
||||
, tags :: ![Tag]
|
||||
, sqlConfig :: !SqlConfig
|
||||
|
|
@ -384,22 +394,24 @@ type AcntID = T.Text
|
|||
|
||||
type TagID = T.Text
|
||||
|
||||
data Statement
|
||||
= StmtManual !Manual
|
||||
| StmtImport !Import
|
||||
type HistTransfer = Transfer AcntID CurID DatePat Decimal
|
||||
|
||||
data History
|
||||
= HistTransfer !HistTransfer
|
||||
| HistStatement !Statement
|
||||
deriving (Eq, Hashable, Generic, FromDhall)
|
||||
|
||||
type ExpSplit = Split SplitAcnt (Maybe SplitNum) SplitCur TagID
|
||||
type ExpSplit = Entry SplitAcnt (Maybe EntryNumGetter) SplitCur TagID
|
||||
|
||||
instance FromDhall ExpSplit
|
||||
|
||||
deriving instance (Show a, Show c, Show v, Show t) => Show (Split a v c t)
|
||||
deriving instance (Show a, Show c, Show v, Show t) => Show (Entry a v c t)
|
||||
|
||||
deriving instance Generic (Split a v c t)
|
||||
deriving instance Generic (Entry a v c t)
|
||||
|
||||
deriving instance (Hashable a, Hashable v, Hashable c, Hashable t) => Hashable (Split a v c t)
|
||||
deriving instance (Hashable a, Hashable v, Hashable c, Hashable t) => Hashable (Entry a v c t)
|
||||
|
||||
deriving instance (Eq a, Eq v, Eq c, Eq t) => Eq (Split a v c t)
|
||||
deriving instance (Eq a, Eq v, Eq c, Eq t) => Eq (Entry a v c t)
|
||||
|
||||
data Tx s = Tx
|
||||
{ txDescr :: !T.Text
|
||||
|
|
@ -422,7 +434,7 @@ data TxOpts re = TxOpts
|
|||
}
|
||||
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
||||
|
||||
data Import = Import
|
||||
data Statement = Statement
|
||||
{ impPaths :: ![FilePath]
|
||||
, impMatches :: ![Match T.Text]
|
||||
, impDelim :: !Word
|
||||
|
|
@ -466,7 +478,7 @@ type FieldMap k v = Field k (M.Map k v)
|
|||
|
||||
data MatchOther re
|
||||
= Desc !(Field T.Text re)
|
||||
| Val !(Field T.Text MatchVal)
|
||||
| Val !(Field T.Text ValMatcher)
|
||||
deriving (Eq, Hashable, Generic, FromDhall, Functor, Foldable, Traversable)
|
||||
|
||||
deriving instance Show (MatchOther T.Text)
|
||||
|
|
@ -479,8 +491,8 @@ data ToTx = ToTx
|
|||
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
||||
|
||||
data Match re = Match
|
||||
{ mDate :: !(Maybe MatchDate)
|
||||
, mVal :: !MatchVal
|
||||
{ mDate :: !(Maybe DateMatcher)
|
||||
, mVal :: !ValMatcher
|
||||
, mDesc :: !(Maybe re)
|
||||
, mOther :: ![MatchOther re]
|
||||
, mTx :: !(Maybe ToTx)
|
||||
|
|
@ -583,7 +595,7 @@ data DBState = DBState
|
|||
|
||||
type MappingT m = ReaderT DBState (SqlPersistT m)
|
||||
|
||||
type KeySplit = Split AccountRId Rational CurrencyRId TagRId
|
||||
type KeySplit = Entry AccountRId Rational CurrencyRId TagRId
|
||||
|
||||
type KeyTx = Tx KeySplit
|
||||
|
||||
|
|
@ -676,9 +688,9 @@ accountSign IncomeT = Credit
|
|||
accountSign LiabilityT = Credit
|
||||
accountSign EquityT = Credit
|
||||
|
||||
type RawSplit = Split AcntID (Maybe Rational) CurID TagID
|
||||
type RawSplit = Entry AcntID (Maybe Rational) CurID TagID
|
||||
|
||||
type BalSplit = Split AcntID Rational CurID TagID
|
||||
type BalSplit = Entry AcntID Rational CurID TagID
|
||||
|
||||
type RawTx = Tx RawSplit
|
||||
|
||||
|
|
@ -720,7 +732,7 @@ data InsertError
|
|||
| ConversionError !T.Text
|
||||
| LookupError !LookupSuberr !T.Text
|
||||
| BalanceError !BalanceType !CurID ![RawSplit]
|
||||
| IncomeError !DatePat
|
||||
| IncomeError !Day !T.Text !Rational
|
||||
| PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
|
||||
| BoundsError !Gregorian !(Maybe Gregorian)
|
||||
| StatementError ![TxRecord] ![MatchRe]
|
||||
|
|
|
|||
|
|
@ -97,22 +97,22 @@ gregMTup GregorianM {gmYear, gmMonth} =
|
|||
|
||||
data YMD_ = Y_ !Integer | YM_ !Integer !Int | YMD_ !Integer !Int !Int
|
||||
|
||||
fromMatchYMD :: MatchYMD -> YMD_
|
||||
fromMatchYMD m = case m of
|
||||
fromYMDMatcher :: YMDMatcher -> YMD_
|
||||
fromYMDMatcher m = case m of
|
||||
Y y -> Y_ $ fromIntegral y
|
||||
YM g -> uncurry YM_ $ gregMTup g
|
||||
YMD g -> uncurry3 YMD_ $ gregTup g
|
||||
|
||||
compareDate :: MatchDate -> Day -> Ordering
|
||||
compareDate :: DateMatcher -> Day -> Ordering
|
||||
compareDate (On md) x =
|
||||
case fromMatchYMD md of
|
||||
case fromYMDMatcher md of
|
||||
Y_ y' -> compare y y'
|
||||
YM_ y' m' -> compare (y, m) (y', m')
|
||||
YMD_ y' m' d' -> compare (y, m, d) (y', m', d')
|
||||
where
|
||||
(y, m, d) = toGregorian x
|
||||
compareDate (In md offset) x = do
|
||||
case fromMatchYMD md of
|
||||
case fromYMDMatcher md of
|
||||
Y_ y' -> compareRange y' y
|
||||
YM_ y' m' -> compareRange (toMonth y' m') $ toMonth y m
|
||||
YMD_ y' m' d' ->
|
||||
|
|
@ -172,7 +172,7 @@ toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> EitherErrs RawTx
|
|||
toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} =
|
||||
concatEithers2 acRes ssRes $ \(a_, c_) ss_ ->
|
||||
let fromSplit =
|
||||
Split
|
||||
Entry
|
||||
{ sAcnt = a_
|
||||
, sCurrency = c_
|
||||
, sValue = Just trAmount
|
||||
|
|
@ -188,8 +188,8 @@ toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} =
|
|||
acRes = concatEithers2 (resolveAcnt r sa) (resolveCurrency r sc) (,)
|
||||
ssRes = concatEithersL $ fmap (resolveSplit r) toSplits
|
||||
|
||||
valMatches :: MatchVal -> Rational -> EitherErr Bool
|
||||
valMatches MatchVal {mvDen, mvSign, mvNum, mvPrec} x
|
||||
valMatches :: ValMatcher -> Rational -> EitherErr Bool
|
||||
valMatches ValMatcher {mvDen, mvSign, mvNum, mvPrec} x
|
||||
| Just d_ <- mvDen, d_ >= p = Left $ MatchValPrecisionError d_ p
|
||||
| otherwise =
|
||||
Right $
|
||||
|
|
@ -202,7 +202,7 @@ valMatches MatchVal {mvDen, mvSign, mvNum, mvPrec} x
|
|||
s = signum x >= 0
|
||||
checkMaybe = maybe True
|
||||
|
||||
dateMatches :: MatchDate -> Day -> Bool
|
||||
dateMatches :: DateMatcher -> Day -> Bool
|
||||
dateMatches md = (EQ ==) . compareDate md
|
||||
|
||||
otherMatches :: M.Map T.Text T.Text -> MatchOtherRe -> EitherErr Bool
|
||||
|
|
@ -213,14 +213,14 @@ otherMatches dict m = case m of
|
|||
lookup_ t n = lookupErr (MatchField t) n dict
|
||||
|
||||
resolveSplit :: TxRecord -> ExpSplit -> EitherErrs RawSplit
|
||||
resolveSplit r s@Split {sAcnt = a, sValue = v, sCurrency = c} =
|
||||
resolveSplit r s@Entry {sAcnt = a, sValue = v, sCurrency = c} =
|
||||
concatEithers2 acRes valRes $
|
||||
\(a_, c_) v_ -> (s {sAcnt = a_, sValue = v_, sCurrency = c_})
|
||||
where
|
||||
acRes = concatEithers2 (resolveAcnt r a) (resolveCurrency r c) (,)
|
||||
valRes = plural $ mapM (resolveValue r) v
|
||||
|
||||
resolveValue :: TxRecord -> SplitNum -> EitherErr Rational
|
||||
resolveValue :: TxRecord -> EntryNumGetter -> EitherErr Rational
|
||||
resolveValue r s = case s of
|
||||
(LookupN t) -> readRational =<< lookupErr SplitValField t (trOther r)
|
||||
(ConstN c) -> Right $ dec2Rat c
|
||||
|
|
@ -371,8 +371,16 @@ showError other = case other of
|
|||
idName TagField = "tag"
|
||||
matchName MatchNumeric = "numeric"
|
||||
matchName MatchText = "text"
|
||||
(IncomeError dp) ->
|
||||
[T.append "Income allocations exceed total: datepattern=" $ showT dp]
|
||||
(IncomeError day name balance) ->
|
||||
[ T.unwords
|
||||
[ "Income allocations for budget"
|
||||
, singleQuote name
|
||||
, "exceed total on day"
|
||||
, showT day
|
||||
, "where balance is"
|
||||
, showT balance
|
||||
]
|
||||
]
|
||||
(BalanceError t cur rss) ->
|
||||
[ T.unwords
|
||||
[ msg
|
||||
|
|
@ -406,8 +414,8 @@ showMatch Match {mDate = d, mVal = v, mDesc = e, mOther = o, mTimes = n, mPriori
|
|||
T.append "Unused match: " $ keyVals [(x, y) | (x, Just y) <- kvs]
|
||||
where
|
||||
kvs =
|
||||
[ ("date", showMatchDate <$> d)
|
||||
, ("val", showMatchVal v)
|
||||
[ ("date", showDateMatcher <$> d)
|
||||
, ("val", showValMatcher v)
|
||||
, ("desc", fst <$> e)
|
||||
, ("other", others)
|
||||
, ("counter", Just $ maybe "Inf" showT n)
|
||||
|
|
@ -420,14 +428,14 @@ showMatch Match {mDate = d, mVal = v, mDesc = e, mOther = o, mTimes = n, mPriori
|
|||
-- | Convert match date to text
|
||||
-- Single date matches will just show the single date, and ranged matches will
|
||||
-- show an interval like [YY-MM-DD, YY-MM-DD)
|
||||
showMatchDate :: MatchDate -> T.Text
|
||||
showMatchDate md = case md of
|
||||
(On x) -> showMatchYMD x
|
||||
(In start n) -> T.concat ["[", showMatchYMD start, " ", showYMD_ end, ")"]
|
||||
showDateMatcher :: DateMatcher -> T.Text
|
||||
showDateMatcher md = case md of
|
||||
(On x) -> showYMDMatcher x
|
||||
(In start n) -> T.concat ["[", showYMDMatcher start, " ", showYMD_ end, ")"]
|
||||
where
|
||||
-- TODO not DRY (this shifting thing happens during the comparison
|
||||
-- function (kinda)
|
||||
end = case fromMatchYMD start of
|
||||
end = case fromYMDMatcher start of
|
||||
Y_ y -> Y_ $ y + fromIntegral n
|
||||
YM_ y m ->
|
||||
let (y_, m_) = divMod (m + fromIntegral n - 1) 12
|
||||
|
|
@ -439,8 +447,8 @@ showMatchDate md = case md of
|
|||
fromGregorian y m d
|
||||
|
||||
-- | convert YMD match to text
|
||||
showMatchYMD :: MatchYMD -> T.Text
|
||||
showMatchYMD = showYMD_ . fromMatchYMD
|
||||
showYMDMatcher :: YMDMatcher -> T.Text
|
||||
showYMDMatcher = showYMD_ . fromYMDMatcher
|
||||
|
||||
showYMD_ :: YMD_ -> T.Text
|
||||
showYMD_ md =
|
||||
|
|
@ -451,9 +459,9 @@ showYMD_ md =
|
|||
YM_ y m -> [fromIntegral y, m]
|
||||
YMD_ y m d -> [fromIntegral y, m, d]
|
||||
|
||||
showMatchVal :: MatchVal -> Maybe T.Text
|
||||
showMatchVal MatchVal {mvSign = Nothing, mvNum = Nothing, mvDen = Nothing} = Nothing
|
||||
showMatchVal MatchVal {mvNum, mvDen, mvSign, mvPrec} =
|
||||
showValMatcher :: ValMatcher -> Maybe T.Text
|
||||
showValMatcher ValMatcher {mvSign = Nothing, mvNum = Nothing, mvDen = Nothing} = Nothing
|
||||
showValMatcher ValMatcher {mvNum, mvDen, mvSign, mvPrec} =
|
||||
Just $ singleQuote $ keyVals [(k, v) | (k, Just v) <- kvs]
|
||||
where
|
||||
kvs =
|
||||
|
|
@ -471,11 +479,11 @@ showMatchOther (Val (Field f mv)) =
|
|||
[ "val field"
|
||||
, singleQuote f
|
||||
, "with match value"
|
||||
, singleQuote $ fromMaybe "*" $ showMatchVal mv
|
||||
, singleQuote $ fromMaybe "*" $ showValMatcher mv
|
||||
]
|
||||
|
||||
showSplit :: RawSplit -> T.Text
|
||||
showSplit Split {sAcnt = a, sValue = v, sComment = c} =
|
||||
showSplit Entry {sAcnt = a, sValue = v, sComment = c} =
|
||||
keyVals
|
||||
[ ("account", a)
|
||||
, ("value", T.pack $ show ((fromRational <$> v) :: Maybe Float))
|
||||
|
|
|
|||
Loading…
Reference in New Issue