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

View File

@ -3,6 +3,7 @@ module Internal.Budget (readBudget) where
import Control.Monad.Except import Control.Monad.Except
import Data.Foldable import Data.Foldable
import Internal.Database import Internal.Database
import Internal.History
import Internal.Types.Main import Internal.Types.Main
import Internal.Utils import Internal.Utils
import RIO hiding (to) import RIO hiding (to)
@ -39,12 +40,17 @@ readBudget
, bgtInterval , bgtInterval
} = } =
eitherHash CTBudget b return $ \key -> do eitherHash CTBudget b return $ \key -> do
(intAllos, _) <- combineError intAlloRes acntRes (,) spanRes <- getSpan
let res1 = mapErrors (readIncome key bgtLabel intAllos bgtInterval) bgtIncomes case spanRes of
let res2 = expandTransfers key bgtLabel bgtInterval bgtTransfers Nothing -> return []
txs <- combineError (concat <$> res1) res2 (++) Just budgetSpan -> do
shadow <- addShadowTransfers bgtShadowTransfers txs (intAllos, _) <- combineError intAlloRes acntRes (,)
return $ txs ++ shadow 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 where
acntRes = mapErrors isNotIncomeAcnt alloAcnts acntRes = mapErrors isNotIncomeAcnt alloAcnts
intAlloRes = combineError3 pre_ tax_ post_ (,,) intAlloRes = combineError3 pre_ tax_ post_ (,,)
@ -56,43 +62,13 @@ readBudget
(alloAcnt <$> bgtPretax) (alloAcnt <$> bgtPretax)
++ (alloAcnt <$> bgtTax) ++ (alloAcnt <$> bgtTax)
++ (alloAcnt <$> bgtPosttax) ++ (alloAcnt <$> bgtPosttax)
getSpan = do
entryPair globalSpan <- askDBState kmBudgetInterval
:: (MonadInsertError m, MonadFinance m) case bgtInterval of
=> TaggedAcnt Nothing -> return $ Just globalSpan
-> TaggedAcnt Just bi -> do
-> CurID localSpan <- liftExcept $ resolveDaySpan bi
-> T.Text return $ intersectDaySpan globalSpan localSpan
-> 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
}
sortAllo :: MultiAllocation v -> InsertExcept (DaySpanAllocation v) sortAllo :: MultiAllocation v -> InsertExcept (DaySpanAllocation v)
sortAllo a@Allocation {alloAmts = as} = do 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 :( -- loop into a fold which I don't feel like doing now :(
readIncome readIncome
:: (MonadInsertError m, MonadFinance m) :: (MonadInsertError m, MonadFinance m)
=> CommitR => TxCommit
-> T.Text
-> IntAllocations -> IntAllocations
-> Maybe Interval -> DaySpan
-> Income -> Income
-> m [Tx TxCommit] -> m [Tx TxCommit]
readIncome readIncome
key tc
name
(intPre, intTax, intPost) (intPre, intTax, intPost)
localInterval ds
Income Income
{ incWhen { incWhen
, incCurrency , incCurrency
@ -152,10 +126,9 @@ readIncome
++ (alloAcnt <$> incTaxes) ++ (alloAcnt <$> incTaxes)
++ (alloAcnt <$> incPosttax) ++ (alloAcnt <$> incPosttax)
precRes = lookupCurrencyPrec incCurrency precRes = lookupCurrencyPrec incCurrency
dayRes = askDays incWhen localInterval dayRes = liftExcept $ expandDatePat ds incWhen
start = fromGregorian' $ pStart incPayPeriod start = fromGregorian' $ pStart incPayPeriod
pType' = pType incPayPeriod pType' = pType incPayPeriod
meta = BudgetCommit key name
flatPre = concatMap flattenAllo incPretax flatPre = concatMap flattenAllo incPretax
flatTax = concatMap flattenAllo incTaxes flatTax = concatMap flattenAllo incTaxes
flatPost = concatMap flattenAllo incPosttax flatPost = concatMap flattenAllo incPosttax
@ -182,17 +155,18 @@ readIncome
incCurrency incCurrency
"balance after deductions" "balance after deductions"
(fromRational balance) (fromRational balance)
allos <- mapErrors (allo2Trans meta day incFrom) (pre ++ tax ++ post) allos <- mapErrors (allo2Trans tc day incFrom) (pre ++ tax ++ post)
let bal = let bal =
Tx Tx
{ txCommit = meta { txCommit = tc
, txDate = day , txDate = day
, txPrimary = primary , txPrimary = primary
, txOther = [] , txOther = []
, txDescr = "balance after deductions" , txDescr = "balance after deductions"
} }
-- TODO use real name here
if balance < 0 if balance < 0
then throwError $ InsertException [IncomeError day name balance] then throwError $ InsertException [IncomeError day "" balance]
else return (bal : allos) else return (bal : allos)
periodScaler periodScaler
@ -383,61 +357,6 @@ allocatePost precision aftertax = fmap (fmap go)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Standalone Transfer -- 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 -- shadow transfers

View File

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

View File

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

View File

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