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