From ebef4e0f6b949441b004078500d9b6b49b0215b1 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sat, 1 Jul 2023 18:32:20 -0400 Subject: [PATCH] WIP mostly unify history and budget transfer pipelines --- dhall/Types.dhall | 28 +++--- lib/Internal/Budget.hs | 137 ++++++---------------------- lib/Internal/History.hs | 173 ++++++++++++++++++++++++++---------- lib/Internal/Types/Dhall.hs | 23 ++--- lib/Internal/Utils.hs | 1 + 5 files changed, 176 insertions(+), 186 deletions(-) diff --git a/dhall/Types.dhall b/dhall/Types.dhall index d9dc5d7..a48121e 100644 --- a/dhall/Types.dhall +++ b/dhall/Types.dhall @@ -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 = {- diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs index 7cd60b4..22d5179 100644 --- a/lib/Internal/Budget.hs +++ b/lib/Internal/Budget.hs @@ -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 diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs index b7da1f3..a586ec5 100644 --- a/lib/Internal/History.hs +++ b/lib/Internal/History.hs @@ -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} = diff --git a/lib/Internal/Types/Dhall.hs b/lib/Internal/Types/Dhall.hs index 9fc74cd..31eadd0 100644 --- a/lib/Internal/Types/Dhall.hs +++ b/lib/Internal/Types/Dhall.hs @@ -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) diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index 7efa67f..bab86fd 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -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_