ENH update types and use deferred allocation math

This commit is contained in:
Nathan Dwarshuis 2023-04-30 00:16:06 -04:00
parent c2c30caf69
commit 4098e72060
5 changed files with 1270 additions and 538 deletions

File diff suppressed because it is too large Load Diff

View File

@ -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

View File

@ -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

View File

@ -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]

View File

@ -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))