WIP mostly unify history and budget transfer pipelines

This commit is contained in:
Nathan Dwarshuis 2023-07-01 18:32:20 -04:00
parent 5c1d2bce9d
commit ebef4e0f6b
5 changed files with 176 additions and 186 deletions

View File

@ -714,11 +714,19 @@ let Transfer =
, transAmounts : List (Amount w v)
}
let TaggedAcnt =
{-
An account with a tag
-}
{ Type = { taAcnt : AcntID, taTags : List TagID }
, default.taTags = [] : List TagID
}
let HistTransfer =
{-
A manually specified historical transfer
-}
Transfer AcntID CurID DatePat TransferValue.Type
Transfer TaggedAcnt.Type CurID DatePat TransferValue.Type
let Statement =
{-
@ -755,12 +763,6 @@ let History =
-}
< HistTransfer : HistTransfer | HistStatement : Statement >
let TaggedAcnt =
{-
An account with a tag
-}
{ taAcnt : AcntID, taTags : List TagID }
let Allocation =
{-
How to allocate a given budget stream. This can be thought of as a Transfer
@ -768,7 +770,7 @@ let Allocation =
-}
\(w : Type) ->
\(v : Type) ->
{ alloTo : TaggedAcnt
{ alloTo : TaggedAcnt.Type
, alloAmts : List (Amount w v)
, alloCur :
{-TODO allow exchanges here-}
@ -958,13 +960,13 @@ let Income =
This must be an income AcntID, and is the only place income
accounts may be specified in the entire budget.
-}
TaggedAcnt
TaggedAcnt.Type
, incToBal :
{-
The account to which to send the remainder of the income stream
(if any) after all allocations have been applied.
-}
TaggedAcnt
TaggedAcnt.Type
}
, default =
{ incPretax = [] : List (SingleAllocation PretaxValue)
@ -1034,12 +1036,12 @@ let ShadowTransfer =
{-
Source of this transfer
-}
TaggedAcnt
TaggedAcnt.Type
, stTo :
{-
Destination of this transfer.
-}
TaggedAcnt
TaggedAcnt.Type
, stCurrency :
{-
Currency of this transfer.
@ -1070,7 +1072,7 @@ let BudgetTransfer =
{-
A manually specified transaction for a budget
-}
Transfer TaggedAcnt CurID DatePat TransferValue.Type
HistTransfer
let Budget =
{-

View File

@ -3,6 +3,7 @@ module Internal.Budget (readBudget) where
import Control.Monad.Except
import Data.Foldable
import Internal.Database
import Internal.History
import Internal.Types.Main
import Internal.Utils
import RIO hiding (to)
@ -39,12 +40,17 @@ readBudget
, bgtInterval
} =
eitherHash CTBudget b return $ \key -> do
(intAllos, _) <- combineError intAlloRes acntRes (,)
let res1 = mapErrors (readIncome key bgtLabel intAllos bgtInterval) bgtIncomes
let res2 = expandTransfers key bgtLabel bgtInterval bgtTransfers
txs <- combineError (concat <$> res1) res2 (++)
shadow <- addShadowTransfers bgtShadowTransfers txs
return $ txs ++ shadow
spanRes <- getSpan
case spanRes of
Nothing -> return []
Just budgetSpan -> do
(intAllos, _) <- combineError intAlloRes acntRes (,)
let tc = BudgetCommit key bgtLabel
let res1 = mapErrors (readIncome tc intAllos budgetSpan) bgtIncomes
let res2 = expandTransfers tc (Just budgetSpan) bgtTransfers
txs <- combineError (concat <$> res1) res2 (++)
shadow <- addShadowTransfers bgtShadowTransfers txs
return $ txs ++ shadow
where
acntRes = mapErrors isNotIncomeAcnt alloAcnts
intAlloRes = combineError3 pre_ tax_ post_ (,,)
@ -56,43 +62,13 @@ readBudget
(alloAcnt <$> bgtPretax)
++ (alloAcnt <$> bgtTax)
++ (alloAcnt <$> bgtPosttax)
entryPair
:: (MonadInsertError m, MonadFinance m)
=> TaggedAcnt
-> TaggedAcnt
-> CurID
-> T.Text
-> Double
-> m (EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational))
entryPair = entryPair_ (fmap (EntryValue TFixed) . roundPrecisionCur)
entryPair_
:: (MonadInsertError m, MonadFinance m)
=> (CurrencyPrec -> v -> v')
-> TaggedAcnt
-> TaggedAcnt
-> CurID
-> T.Text
-> v
-> m (EntrySet AcntID CurrencyPrec TagID Rational v')
entryPair_ f from to curid com val = do
cp <- lookupCurrency curid
return $ pair cp from to (f cp val)
where
halfEntry :: a -> [t] -> HalfEntrySet a c t v
halfEntry a ts =
HalfEntrySet
{ hesPrimary = Entry {eAcnt = a, eValue = (), eComment = com, eTags = ts}
, hesOther = []
}
pair cp (TaggedAcnt fa fts) (TaggedAcnt ta tts) v =
EntrySet
{ esCurrency = cp
, esTotalValue = v
, esFrom = halfEntry fa fts
, esTo = halfEntry ta tts
}
getSpan = do
globalSpan <- askDBState kmBudgetInterval
case bgtInterval of
Nothing -> return $ Just globalSpan
Just bi -> do
localSpan <- liftExcept $ resolveDaySpan bi
return $ intersectDaySpan globalSpan localSpan
sortAllo :: MultiAllocation v -> InsertExcept (DaySpanAllocation v)
sortAllo a@Allocation {alloAmts = as} = do
@ -115,17 +91,15 @@ sortAllo a@Allocation {alloAmts = as} = do
-- loop into a fold which I don't feel like doing now :(
readIncome
:: (MonadInsertError m, MonadFinance m)
=> CommitR
-> T.Text
=> TxCommit
-> IntAllocations
-> Maybe Interval
-> DaySpan
-> Income
-> m [Tx TxCommit]
readIncome
key
name
tc
(intPre, intTax, intPost)
localInterval
ds
Income
{ incWhen
, incCurrency
@ -152,10 +126,9 @@ readIncome
++ (alloAcnt <$> incTaxes)
++ (alloAcnt <$> incPosttax)
precRes = lookupCurrencyPrec incCurrency
dayRes = askDays incWhen localInterval
dayRes = liftExcept $ expandDatePat ds incWhen
start = fromGregorian' $ pStart incPayPeriod
pType' = pType incPayPeriod
meta = BudgetCommit key name
flatPre = concatMap flattenAllo incPretax
flatTax = concatMap flattenAllo incTaxes
flatPost = concatMap flattenAllo incPosttax
@ -182,17 +155,18 @@ readIncome
incCurrency
"balance after deductions"
(fromRational balance)
allos <- mapErrors (allo2Trans meta day incFrom) (pre ++ tax ++ post)
allos <- mapErrors (allo2Trans tc day incFrom) (pre ++ tax ++ post)
let bal =
Tx
{ txCommit = meta
{ txCommit = tc
, txDate = day
, txPrimary = primary
, txOther = []
, txDescr = "balance after deductions"
}
-- TODO use real name here
if balance < 0
then throwError $ InsertException [IncomeError day name balance]
then throwError $ InsertException [IncomeError day "" balance]
else return (bal : allos)
periodScaler
@ -383,61 +357,6 @@ allocatePost precision aftertax = fmap (fmap go)
--------------------------------------------------------------------------------
-- Standalone Transfer
expandTransfers
:: (MonadInsertError m, MonadFinance m)
=> CommitR
-> T.Text
-> Maybe Interval
-> [BudgetTransfer]
-> m [Tx TxCommit]
expandTransfers key name localInterval ts = do
txs <-
fmap (L.sortOn txDate . concat) $
combineErrors $
fmap (expandTransfer key name) ts
case localInterval of
Nothing -> return txs
Just i -> do
bounds <- liftExcept $ resolveDaySpan i
return $ filter (inDaySpan bounds . txDate) txs
expandTransfer
:: (MonadInsertError m, MonadFinance m)
=> CommitR
-> T.Text
-> BudgetTransfer
-> m [Tx TxCommit]
expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} =
concat <$> mapErrors go transAmounts
where
go
Amount
{ amtWhen = pat
, amtValue = TransferValue {tvVal = v, tvType = t}
, amtDesc = desc
} =
withDates pat $ \day -> do
let meta = BudgetCommit key name
p <- entryPair_ (\_ x -> EntryValue t $ toRational x) transFrom transTo transCurrency desc v
return
Tx
{ txCommit = meta
, txDate = day
, txPrimary = p
, txOther = []
, txDescr = desc
}
withDates
:: (MonadFinance m, MonadInsertError m)
=> DatePat
-> (Day -> m a)
-> m [a]
withDates dp f = do
bounds <- askDBState kmBudgetInterval
days <- liftExcept $ expandDatePat bounds dp
combineErrors $ fmap f days
--------------------------------------------------------------------------------
-- shadow transfers

View File

@ -5,6 +5,9 @@ module Internal.History
, splitHistory
, balanceTxs
, updateTx
, entryPair_
, expandTransfers
, entryPair
)
where
@ -30,24 +33,11 @@ import qualified RIO.Vector as V
-- TODO unify this with the transfer system I use in the budget now
readHistTransfer
:: (MonadInsertError m, MonadFinance m)
=> HistTransfer
=> PairedTransfer
-> m (Either CommitR [Tx TxCommit])
readHistTransfer
m@Transfer
{ transFrom = from
, transTo = to
, transCurrency = u
, transAmounts = amts
} =
eitherHash CTManual m return $ \c -> do
bounds <- askDBState kmStatementInterval
let curRes = lookupCurrency u
let go Amount {amtWhen, amtValue, amtDesc} = do
let dayRes = liftExcept $ expandDatePat bounds amtWhen
(days, cur) <- combineError dayRes curRes (,)
let tx day = txPair c day from to cur amtValue amtDesc
return $ fmap tx days
concat <$> mapErrors go amts
readHistTransfer ht = eitherHash CTManual ht return $ \c -> do
bounds <- askDBState kmStatementInterval
expandTransfer (HistoryCommit c) (Just bounds) ht
readHistStmt
:: (MonadUnliftIO m, MonadFinance m)
@ -59,7 +49,7 @@ readHistStmt root i = eitherHash CTImport i return $ \c -> do
bounds <- askDBState kmStatementInterval
return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = HistoryCommit c}) bs
splitHistory :: [History] -> ([HistTransfer], [Statement])
splitHistory :: [History] -> ([PairedTransfer], [Statement])
splitHistory = partitionEithers . fmap go
where
go (HistTransfer x) = Left x
@ -98,38 +88,125 @@ updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. unStaticValue
--------------------------------------------------------------------------------
-- low-level transaction stuff
-- TODO tags here?
txPair
:: CommitR
-> Day
-> AcntID
-> AcntID
-> CurrencyPrec
-> TransferValue
-> T.Text
-> Tx TxCommit
txPair commit day from to cur (TransferValue t v) desc =
Tx
{ txDescr = desc
, txDate = day
, txCommit = HistoryCommit commit
, txPrimary =
EntrySet
{ esTotalValue = EntryValue t $ toRational v
, esCurrency = cur
, esFrom = HalfEntrySet {hesPrimary = entry from, hesOther = []}
, esTo = HalfEntrySet {hesPrimary = entry to, hesOther = []}
}
, txOther = []
}
expandTransfers
:: (MonadInsertError m, MonadFinance m)
=> TxCommit
-> Maybe DaySpan
-> [PairedTransfer]
-> m [Tx TxCommit]
expandTransfers tc localInterval ts =
fmap (L.sortOn txDate . concat) $
combineErrors $
fmap (expandTransfer tc localInterval) ts
expandTransfer
:: (MonadInsertError m, MonadFinance m)
=> TxCommit
-> Maybe DaySpan
-> PairedTransfer
-> m [Tx TxCommit]
expandTransfer tc ds Transfer {transAmounts, transTo, transCurrency, transFrom} = do
txs <- concat <$> mapErrors go transAmounts
return $ case ds of
Nothing -> txs
Just bounds -> filter (inDaySpan bounds . txDate) txs
where
entry a =
Entry
{ eAcnt = a
, eValue = ()
, eComment = ""
, eTags = []
go
Amount
{ amtWhen = pat
, amtValue = TransferValue {tvVal = v, tvType = t}
, amtDesc = desc
} =
withDates pat $ \day -> do
p <- entryPair_ (\_ x -> EntryValue t $ toRational x) transFrom transTo transCurrency desc v
return
Tx
{ txCommit = tc
, txDate = day
, txPrimary = p
, txOther = []
, txDescr = desc
}
entryPair
:: (MonadInsertError m, MonadFinance m)
=> TaggedAcnt
-> TaggedAcnt
-> CurID
-> T.Text
-> Double
-> m (EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational))
entryPair = entryPair_ (fmap (EntryValue TFixed) . roundPrecisionCur)
entryPair_
:: (MonadInsertError m, MonadFinance m)
=> (CurrencyPrec -> v -> v')
-> TaggedAcnt
-> TaggedAcnt
-> CurID
-> T.Text
-> v
-> m (EntrySet AcntID CurrencyPrec TagID Rational v')
entryPair_ f from to curid com val = do
cp <- lookupCurrency curid
return $ pair cp from to (f cp val)
where
halfEntry :: a -> [t] -> HalfEntrySet a c t v
halfEntry a ts =
HalfEntrySet
{ hesPrimary = Entry {eAcnt = a, eValue = (), eComment = com, eTags = ts}
, hesOther = []
}
pair cp (TaggedAcnt fa fts) (TaggedAcnt ta tts) v =
EntrySet
{ esCurrency = cp
, esTotalValue = v
, esFrom = halfEntry fa fts
, esTo = halfEntry ta tts
}
withDates
:: (MonadFinance m, MonadInsertError m)
=> DatePat
-> (Day -> m a)
-> m [a]
withDates dp f = do
bounds <- askDBState kmBudgetInterval
days <- liftExcept $ expandDatePat bounds dp
combineErrors $ fmap f days
-- -- TODO tags here?
-- txPair
-- :: CommitR
-- -> Day
-- -> AcntID
-- -> AcntID
-- -> CurrencyPrec
-- -> TransferValue
-- -> T.Text
-- -> Tx TxCommit
-- txPair commit day from to cur (TransferValue t v) desc =
-- Tx
-- { txDescr = desc
-- , txDate = day
-- , txCommit = HistoryCommit commit
-- , txPrimary =
-- EntrySet
-- { esTotalValue = EntryValue t $ toRational v
-- , esCurrency = cur
-- , esFrom = HalfEntrySet {hesPrimary = entry from, hesOther = []}
-- , esTo = HalfEntrySet {hesPrimary = entry to, hesOther = []}
-- }
-- , txOther = []
-- }
-- where
-- entry a =
-- Entry
-- { eAcnt = a
-- , eValue = ()
-- , eComment = ""
-- , eTags = []
-- }
-- resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx CommitR -> m (KeyTx CommitR)
-- resolveTx t@Tx {txEntries = ss} =

View File

@ -40,7 +40,7 @@ makeHaskellTypesWith
, SingleConstructor "LinkedNumGetter" "LinkedNumGetter" "(./dhall/Types.dhall).LinkedNumGetter.Type"
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
, SingleConstructor "Tag" "Tag" "(./dhall/Types.dhall).Tag"
, SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt"
, SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt.Type"
, SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
, SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
, SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval"
@ -178,14 +178,13 @@ deriving instance Ord DatePat
deriving instance Hashable DatePat
type BudgetTransfer =
Transfer TaggedAcnt CurID DatePat TransferValue
type PairedTransfer = Transfer TaggedAcnt CurID DatePat TransferValue
deriving instance Hashable BudgetTransfer
deriving instance Hashable PairedTransfer
deriving instance Generic BudgetTransfer
deriving instance Generic PairedTransfer
deriving instance FromDhall BudgetTransfer
deriving instance FromDhall PairedTransfer
data Budget = Budget
{ bgtLabel :: Text
@ -193,7 +192,7 @@ data Budget = Budget
, bgtPretax :: [MultiAllocation PretaxValue]
, bgtTax :: [MultiAllocation TaxValue]
, bgtPosttax :: [MultiAllocation PosttaxValue]
, bgtTransfers :: [BudgetTransfer]
, bgtTransfers :: [PairedTransfer]
, bgtShadowTransfers :: [ShadowTransfer]
, bgtInterval :: !(Maybe Interval)
}
@ -420,16 +419,8 @@ type AcntID = T.Text
type TagID = T.Text
type HistTransfer = Transfer AcntID CurID DatePat TransferValue
deriving instance Generic HistTransfer
deriving instance Hashable HistTransfer
deriving instance FromDhall HistTransfer
data History
= HistTransfer !HistTransfer
= HistTransfer !PairedTransfer
| HistStatement !Statement
deriving (Eq, Generic, Hashable, FromDhall)

View File

@ -274,6 +274,7 @@ intersectDaySpan a b =
resolveDaySpan_ :: Gregorian -> Interval -> InsertExcept DaySpan
resolveDaySpan_ def Interval {intStart = s, intEnd = e} =
-- TODO the default isn't checked here :/
case fromGregorian' <$> e of
Nothing -> return $ toDaySpan_ $ fromGregorian' def
Just e_