From 1ae670187a88a76d9f447f9e9c190c9f6cbbe62e Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Fri, 30 Jun 2023 23:54:39 -0400 Subject: [PATCH] WIP unify history and budget pipelines --- dhall/Types.dhall | 39 +--- lib/Internal/Budget.hs | 434 +++++++++++++++++++----------------- lib/Internal/History.hs | 48 ++-- lib/Internal/Types/Dhall.hs | 14 +- lib/Internal/Types/Main.hs | 12 +- lib/Internal/Utils.hs | 6 +- 6 files changed, 270 insertions(+), 283 deletions(-) diff --git a/dhall/Types.dhall b/dhall/Types.dhall index d181022..d9dc5d7 100644 --- a/dhall/Types.dhall +++ b/dhall/Types.dhall @@ -681,39 +681,6 @@ let Amount = \(v : Type) -> { amtWhen : w, amtValue : v, amtDesc : Text } -let Exchange = - {- - A currency exchange. - -} - { xFromCur : - {- - Starting currency of the exchange. - -} - CurID - , xToCur : - {- - Ending currency of the exchange. - -} - CurID - , xAcnt : - {- - account in which the exchange will be documented. - -} - AcntID - , xRate : - {- - The exchange rate between the currencies. - -} - Double - } - -let TransferCurrency = - {- - Means to represent currency in a transcaction; either single fixed currency - or two currencies with an exchange rate. - -} - < NoX : CurID | X : Exchange > - let TransferType = {- The type of a budget transfer. @@ -1077,7 +1044,7 @@ let ShadowTransfer = {- Currency of this transfer. -} - TransferCurrency + CurID , stDesc : {- Description of this transfer. @@ -1103,7 +1070,7 @@ let BudgetTransfer = {- A manually specified transaction for a budget -} - Transfer TaggedAcnt TransferCurrency DatePat TransferValue.Type + Transfer TaggedAcnt CurID DatePat TransferValue.Type let Budget = {- @@ -1173,8 +1140,6 @@ in { CurID , TransferMatcher , ShadowTransfer , AcntSet - , TransferCurrency - , Exchange , TaggedAcnt , AccountTree , Account diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs index 672655d..f95dea6 100644 --- a/lib/Internal/Budget.hs +++ b/lib/Internal/Budget.hs @@ -4,6 +4,7 @@ import Control.Monad.Except import Data.Foldable import Database.Persist.Monad import Internal.Database +import Internal.History import Internal.Types.Main import Internal.Utils import RIO hiding (to) @@ -44,9 +45,9 @@ insertBudget let res1 = mapErrors (insertIncome key bgtLabel intAllos bgtInterval) bgtIncomes let res2 = expandTransfers key bgtLabel bgtInterval bgtTransfers txs <- combineError (concat <$> res1) res2 (++) - m <- askDBState kmCurrency - shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs - void $ mapErrors insertBudgetTx $ balanceTransfers $ txs ++ shadow + shadow <- addShadowTransfers bgtShadowTransfers txs + (_, toIns) <- balanceTxs $ fmap ToInsert $ txs ++ shadow + void $ insertBudgetTx toIns where acntRes = mapErrors isNotIncomeAcnt alloAcnts intAlloRes = combineError3 pre_ tax_ post_ (,,) @@ -61,69 +62,94 @@ insertBudget -- TODO need to systematically make this function match the history version, -- which will allow me to use the same balancing algorithm for both -balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer] -balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen - where - go bals f@FlatTransfer {ftFrom, ftTo, ftValue = UnbalancedValue {cvValue, cvType}} = - let balTo = M.findWithDefault 0 ftTo bals - x = amtToMove balTo cvType cvValue - bals' = mapAdd_ ftTo x $ mapAdd_ ftFrom (-x) bals - in (bals', f {ftValue = 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 _ BTFixed x = x - amtToMove bal BTPercent x = -(x / 100 * bal) - amtToMove bal BTTarget x = x - bal +-- balanceTransfers :: [Tx BudgetMeta] -> [KeyEntry] +-- balanceTransfers = undefined + +-- balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen +-- where +-- go bals f@FlatTransfer {ftFrom, ftTo, ftValue = UnbalancedValue {cvValue, cvType}} = +-- let balTo = M.findWithDefault 0 ftTo bals +-- x = amtToMove balTo cvType cvValue +-- bals' = mapAdd_ ftTo x $ mapAdd_ ftFrom (-x) bals +-- in (bals', f {ftValue = 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 _ TFixed x = x +-- amtToMove bal TPercent x = -(x / 100 * bal) +-- amtToMove bal TBalance x = x - bal insertBudgetTx :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) - => BalancedTransfer + => [InsertTx BudgetMeta] -> m () -insertBudgetTx FlatTransfer {ftFrom, ftTo, ftMeta, ftCur, ftValue, ftDesc, ftWhen} = do - ((sFrom, sTo), exchange) <- entryPair ftFrom ftTo ftCur ftValue - insertPair sFrom sTo - forM_ exchange $ uncurry insertPair +insertBudgetTx toInsert = do + forM_ (groupKey (commitRHash . bmCommit) $ (\x -> (itxCommit x, x)) <$> toInsert) $ + \(c, ts) -> do + ck <- insert $ bmCommit c + mapM_ (insertTx ck) ts where - insertPair from to = do - k <- insert $ TransactionR (bmCommit ftMeta) ftWhen ftDesc - insertBudgetLabel k from - insertBudgetLabel k to - insertBudgetLabel k entry = do + insertTx c InsertTx {itxDate = d, itxDescr = e, itxEntries = ss, itxCommit = BudgetMeta {bmName}} = do + let anyDeferred = any (isJust . feDeferred) ss + k <- insert $ TransactionR c d e anyDeferred + mapM_ (insertBudgetLabel bmName k) ss + insertBudgetLabel n k entry = do sk <- insertEntry k entry - insert_ $ BudgetLabelR sk $ bmName ftMeta + insert_ $ BudgetLabelR sk n + +-- insertBudgetTx +-- :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) +-- => BalancedTransfer +-- -> m () +-- insertBudgetTx FlatTransfer {ftFrom, ftTo, ftMeta, ftCur, ftValue, ftDesc, ftWhen} = do +-- ((sFrom, sTo), exchange) <- entryPair ftFrom ftTo ftCur ftValue +-- insertPair sFrom sTo +-- forM_ exchange $ uncurry insertPair +-- where +-- insertPair from to = do +-- k <- insert $ TransactionR (bmCommit ftMeta) ftWhen ftDesc +-- insertBudgetLabel k from +-- insertBudgetLabel k to +-- insertBudgetLabel k entry = do +-- sk <- insertEntry k entry +-- insert_ $ BudgetLabelR sk $ bmName ftMeta entryPair :: (MonadInsertError m, MonadFinance m) => TaggedAcnt -> TaggedAcnt - -> BudgetCurrency - -> Rational - -> m (EntryPair, Maybe EntryPair) -entryPair from to cur val = case cur of - NoX curid -> (,Nothing) <$> pair curid from to val - X Exchange {xFromCur, xToCur, xAcnt, xRate} -> do - let middle = TaggedAcnt xAcnt [] - let res1 = pair xFromCur from middle val - let res2 = pair xToCur middle to (val * roundPrecision 3 xRate) - combineError res1 res2 $ \a b -> (a, Just b) + -> 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 - pair curid from_ to_ v = do - let s1 = entry curid from_ (-v) - let s2 = entry curid to_ v - combineError s1 s2 (,) - entry c TaggedAcnt {taAcnt, taTags} v = - resolveEntry $ - FullEntry - { feCurrency = c - , feEntry = - Entry - { eAcnt = taAcnt - , eValue = v - , eComment = "" - , eTags = taTags - } - } + 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 a@Allocation {alloAmts = as} = do @@ -151,7 +177,7 @@ insertIncome -> IntAllocations -> Maybe Interval -> Income - -> m [UnbalancedTransfer] + -> m [Tx BudgetMeta] insertIncome key name @@ -197,27 +223,34 @@ insertIncome let (preDeductions, pre) = allocatePre precision gross $ flatPre ++ concatMap (selectAllos day) intPre - tax = + let tax = allocateTax precision gross preDeductions scaler $ flatTax ++ concatMap (selectAllos day) intTax aftertaxGross = gross - sumAllos (tax ++ pre) - post = + let post = allocatePost precision aftertaxGross $ flatPost ++ concatMap (selectAllos day) intPost - balance = aftertaxGross - sumAllos post - bal = - FlatTransfer - { ftMeta = meta - , ftWhen = day - , ftFrom = incFrom - , ftCur = NoX incCurrency - , ftTo = incToBal - , ftValue = UnbalancedValue BTFixed balance - , ftDesc = "balance after deductions" + let balance = aftertaxGross - sumAllos post + -- TODO double or rational here? + primary <- + entryPair + incFrom + incToBal + incCurrency + "balance after deductions" + (fromRational balance) + allos <- mapErrors (allo2Trans meta day incFrom) (pre ++ tax ++ post) + let bal = + Tx + { txCommit = meta + , txDate = day + , txPrimary = primary + , txOther = [] + , txDescr = "balance after deductions" } - in if balance < 0 - then throwError $ InsertException [IncomeError day name balance] - else return (bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post)) + if balance < 0 + then throwError $ InsertException [IncomeError day name balance] + else return (bal : allos) periodScaler :: PeriodType @@ -298,7 +331,7 @@ flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts where go Amount {amtValue, amtDesc} = FlatAllocation - { faCur = NoX alloCur + { faCur = alloCur , faTo = alloTo , faValue = amtValue , faDesc = amtDesc @@ -311,28 +344,30 @@ selectAllos day Allocation {alloAmts, alloCur, alloTo} = where go Amount {amtValue, amtDesc} = FlatAllocation - { faCur = NoX alloCur + { faCur = alloCur , faTo = alloTo , faValue = amtValue , faDesc = amtDesc } allo2Trans - :: BudgetMeta + :: (MonadInsertError m, MonadFinance m) + => BudgetMeta -> Day -> TaggedAcnt -> FlatAllocation Rational - -> UnbalancedTransfer -allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} = - FlatTransfer - { ftMeta = meta - , ftWhen = day - , ftFrom = from - , ftCur = faCur - , ftTo = faTo - , ftValue = UnbalancedValue BTFixed faValue - , ftDesc = faDesc - } + -> m (Tx BudgetMeta) +allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} = do + -- TODO double here? + p <- entryPair from faTo faCur faDesc (fromRational faValue) + return + Tx + { txCommit = meta + , txDate = day + , txPrimary = p + , txOther = [] + , txDescr = faDesc + } allocatePre :: Natural @@ -411,46 +446,43 @@ expandTransfers -> T.Text -> Maybe Interval -> [BudgetTransfer] - -> m [UnbalancedTransfer] + -> m [Tx BudgetMeta] expandTransfers key name localInterval ts = do txs <- - fmap (L.sortOn ftWhen . concat) $ + 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 . ftWhen) txs + return $ filter (inDaySpan bounds . txDate) txs expandTransfer :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) => CommitRId -> T.Text -> BudgetTransfer - -> m [UnbalancedTransfer] + -> m [Tx BudgetMeta] expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = do - precision <- lookupCurrencyPrec $ initialCurrency transCurrency - fmap concat $ combineErrors $ fmap (go precision) transAmounts + fmap concat $ mapErrors go transAmounts where go - precision Amount { amtWhen = pat - , amtValue = BudgetTransferValue {btVal = v, btType = y} + , amtValue = TransferValue {tvVal = v, tvType = t} , amtDesc = desc } = withDates pat $ \day -> do let meta = BudgetMeta {bmCommit = key, bmName = name} + p <- entryPair_ (\_ x -> EntryValue t $ toRational x) transFrom transTo transCurrency desc v return - FlatTransfer - { ftMeta = meta - , ftWhen = day - , ftCur = transCurrency - , ftFrom = transFrom - , ftTo = transTo - , ftValue = UnbalancedValue y $ roundPrecision precision v - , ftDesc = desc + Tx + { txCommit = meta + , txDate = day + , txPrimary = p + , txOther = [] + , txDescr = desc } withDates @@ -468,63 +500,53 @@ withDates dp f = do -- TODO this is going to be O(n*m), which might be a problem? addShadowTransfers - :: CurrencyMap - -> [ShadowTransfer] - -> [UnbalancedTransfer] - -> InsertExcept [UnbalancedTransfer] -addShadowTransfers cm ms txs = - fmap catMaybes $ - combineErrors $ - fmap (uncurry (fromShadow cm)) $ - [(t, m) | t <- txs, m <- ms] + :: (MonadInsertError m, MonadFinance m) + => [ShadowTransfer] + -> [Tx BudgetMeta] + -> m [Tx BudgetMeta] +addShadowTransfers ms txs = mapErrors go txs + where + go tx = do + es <- catMaybes <$> mapErrors (fromShadow tx) ms + return $ tx {txOther = es} fromShadow - :: CurrencyMap - -> UnbalancedTransfer + :: (MonadInsertError m, MonadFinance m) + => Tx BudgetMeta -> ShadowTransfer - -> InsertExcept (Maybe UnbalancedTransfer) -fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do - res <- shadowMatches (stMatch t) tx - v <- roundPrecisionCur (initialCurrency stCurrency) cm stRatio - return $ - if not res - then Nothing - else - Just $ - FlatTransfer - { ftMeta = ftMeta tx - , ftWhen = ftWhen tx - , ftCur = stCurrency - , ftFrom = stFrom - , ftTo = stTo - , ftValue = UnbalancedValue stType $ v * cvValue (ftValue tx) - , ftDesc = stDesc - } + -> m (Maybe (EntrySet AcntID CurrencyPrec TagID Rational (Either Double (EntryValue Rational)))) +fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} = do + res <- liftExcept $ shadowMatches stMatch tx + es <- entryPair_ (\_ v -> Left v) stFrom stTo stCurrency stDesc stRatio + return $ if not res then Nothing else Just es -shadowMatches :: TransferMatcher -> UnbalancedTransfer -> InsertExcept Bool -shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do - valRes <- valMatches tmVal $ cvValue $ ftValue tx +shadowMatches :: TransferMatcher -> Tx BudgetMeta -> InsertExcept Bool +shadowMatches TransferMatcher {tmFrom, tmTo, tmDate} Tx {txPrimary, txDate} = do + -- NOTE this will only match against the primary entry set since those + -- are what are guaranteed to exist from a transfer + -- valRes <- valMatches tmVal $ esTotalValue $ txPrimary return $ - memberMaybe (taAcnt $ ftFrom tx) tmFrom - && memberMaybe (taAcnt $ ftTo tx) tmTo - && maybe True (`dateMatches` ftWhen tx) tmDate - && valRes + memberMaybe (eAcnt $ hesPrimary $ esFrom txPrimary) tmFrom + && memberMaybe (eAcnt $ hesPrimary $ esTo txPrimary) tmTo + && maybe True (`dateMatches` txDate) tmDate where + -- && valRes + memberMaybe x AcntSet {asList, asInclude} = (if asInclude then id else not) $ x `elem` asList -------------------------------------------------------------------------------- -- random -initialCurrency :: BudgetCurrency -> CurID -initialCurrency (NoX c) = c -initialCurrency (X Exchange {xFromCur = c}) = c +-- initialCurrency :: TransferCurrency -> CurID +-- initialCurrency (NoX c) = c +-- initialCurrency (X Exchange {xFromCur = c}) = c alloAcnt :: Allocation w v -> AcntID alloAcnt = taAcnt . alloTo data UnbalancedValue = UnbalancedValue - { cvType :: !BudgetTransferType + { cvType :: !TransferType , cvValue :: !Rational } deriving (Show) @@ -533,75 +555,77 @@ data UnbalancedValue = UnbalancedValue -- in the history algorithm, which will entail resolving the budget currency -- stuff earlier in the chain, and preloading multiple entries into this thing -- before balancing. -type UnbalancedTransfer = FlatTransfer UnbalancedValue +-- type UnbalancedTransfer = FlatTransfer UnbalancedValue -ubt2tx :: UnbalancedTransfer -> Tx [EntrySet AcntID CurID TagID Rational] BudgetMeta -ubt2tx - FlatTransfer - { ftFrom - , ftTo - , ftValue - , ftWhen - , ftDesc - , ftMeta - , ftCur - } = - Tx - { txDescr = ftDesc - , txDate = ftWhen - , txEntries = entries ftCur - , txCommit = ftMeta - } - where - entries (NoX curid) = [pair curid ftFrom ftTo ftValue] - entries (X Exchange {xFromCur, xToCur, xAcnt, xRate}) = - let middle = TaggedAcnt xAcnt [] - p1 = pair xFromCur ftFrom middle ftValue - p2 = pair xToCur middle ftTo (ftValue * roundPrecision 3 xRate) - in [p1, p2] - pair c (TaggedAcnt fa fts) (TaggedAcnt ta tts) v = - EntrySet - { esTotalValue = v - , esCurrency = c - , esFrom = - HalfEntrySet - { hesPrimary = - Entry - { eValue = () - , eComment = "" - , eAcnt = fa - , eTags = fts - } - , hesOther = [] - } - , esTo = - HalfEntrySet - { hesPrimary = - Entry - { eValue = () - , eComment = "" - , eAcnt = ta - , eTags = tts - } - , hesOther = [] - } - } +-- ubt2tx :: UnbalancedTransfer -> Tx BudgetMeta +-- ubt2tx +-- FlatTransfer +-- { ftFrom +-- , ftTo +-- , ftValue +-- , ftWhen +-- , ftDesc +-- , ftMeta +-- , ftCur +-- } = +-- Tx +-- { txDescr = ftDesc +-- , txDate = ftWhen +-- , txPrimary = p +-- , txOther = maybeToList os +-- , txCommit = ftMeta +-- } +-- where +-- (p, os) = entries ftCur +-- entries (NoX curid) = (pair curid ftFrom ftTo ftValue, Nothing) +-- entries (X Exchange {xFromCur, xToCur, xAcnt, xRate}) = +-- let middle = TaggedAcnt xAcnt [] +-- p1 = pair xFromCur ftFrom middle ftValue +-- p2 = pair xToCur middle ftTo (ftValue * roundPrecision 3 xRate) +-- in (p1, Just p2) +-- pair c (TaggedAcnt fa fts) (TaggedAcnt ta tts) v = +-- EntrySet +-- { esTotalValue = v +-- , esCurrency = c +-- , esFrom = +-- HalfEntrySet +-- { hesPrimary = +-- Entry +-- { eValue = () +-- , eComment = "" +-- , eAcnt = fa +-- , eTags = fts +-- } +-- , hesOther = [] +-- } +-- , esTo = +-- HalfEntrySet +-- { hesPrimary = +-- Entry +-- { eValue = () +-- , eComment = "" +-- , eAcnt = ta +-- , eTags = tts +-- } +-- , hesOther = [] +-- } +-- } -type BalancedTransfer = FlatTransfer Rational +-- type BalancedTransfer = FlatTransfer Rational -data FlatTransfer v = FlatTransfer - { ftFrom :: !TaggedAcnt - , ftTo :: !TaggedAcnt - , ftValue :: !v - , ftWhen :: !Day - , ftDesc :: !T.Text - , ftMeta :: !BudgetMeta - , ftCur :: !BudgetCurrency - } - deriving (Show) +-- data FlatTransfer v = FlatTransfer +-- { ftFrom :: !TaggedAcnt +-- , ftTo :: !TaggedAcnt +-- , ftValue :: !v +-- , ftWhen :: !Day +-- , ftDesc :: !T.Text +-- , ftMeta :: !BudgetMeta +-- , ftCur :: !TransferCurrency +-- } +-- deriving (Show) data BudgetMeta = BudgetMeta - { bmCommit :: !CommitRId + { bmCommit :: !CommitR , bmName :: !T.Text } deriving (Show) @@ -622,6 +646,6 @@ data FlatAllocation v = FlatAllocation { faValue :: !v , faDesc :: !T.Text , faTo :: !TaggedAcnt - , faCur :: !BudgetCurrency + , faCur :: !CurID } deriving (Functor, Show) diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs index 9ccba68..f5d67d6 100644 --- a/lib/Internal/History.hs +++ b/lib/Internal/History.hs @@ -3,6 +3,7 @@ module Internal.History , readHistTransfer , insertHistory , splitHistory + , balanceTxs ) where @@ -75,7 +76,7 @@ splitHistory = partitionEithers . fmap go insertHistory :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) - => [EntryBin] + => [EntryBin CommitR] -> m () insertHistory hs = do (toUpdate, toInsert) <- balanceTxs hs @@ -95,17 +96,17 @@ txPair -> AcntID -> AcntID -> CurrencyPrec - -> Double + -> TransferValue -> T.Text -> Tx CommitR -txPair commit day from to cur val desc = +txPair commit day from to cur (TransferValue t v) desc = Tx { txDescr = desc , txDate = day , txCommit = commit , txPrimary = EntrySet - { esTotalValue = -(roundPrecisionCur cur val) + { esTotalValue = EntryValue t $ toRational v , esCurrency = cur , esFrom = HalfEntrySet {hesPrimary = entry from, hesOther = []} , esTo = HalfEntrySet {hesPrimary = entry to, hesOther = []} @@ -125,7 +126,7 @@ txPair commit day from to cur val desc = -- resolveTx t@Tx {txEntries = ss} = -- (\kss -> t {txEntries = kss}) <$> mapErrors resolveEntry ss -insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m () +insertTx :: MonadSqlQuery m => CommitRId -> InsertTx CommitR -> m () insertTx c InsertTx {itxDate = d, itxDescr = e, itxEntries = ss} = do let anyDeferred = any (isJust . feDeferred) ss k <- insert $ TransactionR c d e anyDeferred @@ -348,8 +349,8 @@ matchNonDates ms = go ([], [], initZipper ms) balanceTxs :: (MonadInsertError m, MonadFinance m) - => [EntryBin] - -> m ([UEBalanced], [InsertTx]) + => [EntryBin a] + -> m ([UEBalanced], [InsertTx a]) balanceTxs ebs = first concat . partitionEithers . catMaybes <$> evalStateT (mapErrors go $ L.sortOn binDate ebs) M.empty @@ -358,22 +359,27 @@ balanceTxs ebs = go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do modify $ mapAdd_ (reAcnt, reCurrency) reValue return Nothing - go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate}) = - let res0 = balanceEntrySet (\_ _ v -> return v) txPrimary - resN = mapErrors (balanceEntrySet primaryBalance) txOther - in combineError res0 resN $ \e es -> - -- TODO repacking a Tx into almost the same record seems stupid - Just $ - Right $ - InsertTx - { itxDescr = txDescr - , itxDate = txDate - , itxEntries = concat $ e : es - , itxCommit = txCommit - } + go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate}) = do + e <- balanceEntrySet primaryBalance txPrimary + -- TODO this logic is really stupid, I'm balancing the total twice; fix + -- will likely entail making a separate data structure for txs derived + -- from transfers vs statements + let etot = sum $ eValue . feEntry <$> filter ((< 0) . feIndex) e + es <- mapErrors (balanceEntrySet (secondaryBalance etot)) txOther + let tx = + InsertTx + { itxDescr = txDescr + , itxDate = txDate + , itxEntries = concat $ e : es + , itxCommit = txCommit + } + return $ Just $ Right tx primaryBalance Entry {eAcnt} c (EntryValue t v) = findBalance eAcnt c t v + secondaryBalance tot Entry {eAcnt} c val = case val of + Right (EntryValue t v) -> findBalance eAcnt c t v + Left v -> return $ toRational v * tot -binDate :: EntryBin -> Day +binDate :: EntryBin a -> Day binDate (ToUpdate UpdateEntrySet {utDate}) = utDate binDate (ToRead ReadEntry {reDate}) = reDate binDate (ToInsert Tx {txDate}) = txDate diff --git a/lib/Internal/Types/Dhall.hs b/lib/Internal/Types/Dhall.hs index de55bb3..9fc74cd 100644 --- a/lib/Internal/Types/Dhall.hs +++ b/lib/Internal/Types/Dhall.hs @@ -34,7 +34,6 @@ makeHaskellTypesWith , MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher" , MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter" , MultipleConstructors "LinkedEntryNumGetter" "(./dhall/Types.dhall).LinkedEntryNumGetter" - , MultipleConstructors "TransferCurrency" "(./dhall/Types.dhall).TransferCurrency" , MultipleConstructors "TransferType" "(./dhall/Types.dhall).TransferType" , MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod" , MultipleConstructors "PeriodType" "(./dhall/Types.dhall).PeriodType" @@ -55,8 +54,7 @@ makeHaskellTypesWith , 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 "Field" "Field" "(./dhall/Types.dhall).Field" , SingleConstructor "Entry" "Entry" "(./dhall/Types.dhall).Entry" , SingleConstructor "PretaxValue" "PretaxValue" "(./dhall/Types.dhall).PretaxValue" , SingleConstructor "TaxBracket" "TaxBracket" "(./dhall/Types.dhall).TaxBracket" @@ -97,8 +95,6 @@ deriveProduct , "DateMatcher" , "ValMatcher" , "YMDMatcher" - , "TransferCurrency" - , "Exchange" , "EntryNumGetter" , "LinkedNumGetter" , "LinkedEntryNumGetter" @@ -183,7 +179,7 @@ deriving instance Ord DatePat deriving instance Hashable DatePat type BudgetTransfer = - Transfer TaggedAcnt TransferCurrency DatePat TransferValue + Transfer TaggedAcnt CurID DatePat TransferValue deriving instance Hashable BudgetTransfer @@ -272,10 +268,6 @@ 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 TransferCurrency - data Allocation w v = Allocation { alloTo :: TaggedAcnt , alloAmts :: [Amount w v] @@ -428,7 +420,7 @@ type AcntID = T.Text type TagID = T.Text -type HistTransfer = Transfer AcntID CurID DatePat Double +type HistTransfer = Transfer AcntID CurID DatePat TransferValue deriving instance Generic HistTransfer diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs index a5209aa..20b461c 100644 --- a/lib/Internal/Types/Main.hs +++ b/lib/Internal/Types/Main.hs @@ -121,10 +121,10 @@ data UpdateEntrySet = UpdateEntrySet , utTotalValue :: !Rational } -data EntryBin +data EntryBin a = ToUpdate UpdateEntrySet | ToRead ReadEntry - | ToInsert (Tx CommitR) + | ToInsert (Tx a) data InsertEntry a c t = InsertEntry { feCurrency :: !c @@ -221,17 +221,17 @@ data EntrySet a c t v v' = EntrySet data Tx k = Tx { txDescr :: !T.Text , txDate :: !Day - , txPrimary :: !(EntrySet AcntID CurrencyPrec TagID Rational Rational) - , txOther :: ![EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational)] + , txPrimary :: !(EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational)) + , txOther :: ![EntrySet AcntID CurrencyPrec TagID Rational (Either Double (EntryValue Rational))] , txCommit :: !k } deriving (Generic) -data InsertTx = InsertTx +data InsertTx a = InsertTx { itxDescr :: !T.Text , itxDate :: !Day , itxEntries :: ![InsertEntry AccountRId CurrencyRId TagRId] - , itxCommit :: !CommitR + , itxCommit :: !a } deriving (Generic) diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index 2ec919c..7efa67f 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -327,7 +327,7 @@ toTx , txCommit = () , txPrimary = EntrySet - { esTotalValue = roundPrecisionCur cur $ tgScale * fromRational trAmount + { esTotalValue = EntryValue TFixed $ roundPrecisionCur cur $ tgScale * fromRational trAmount , esCurrency = cur , esFrom = f , esTo = t @@ -347,7 +347,7 @@ resolveSubGetter :: MonadFinance m => TxRecord -> TxSubGetter - -> InsertExceptT m (EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational)) + -> InsertExceptT m (EntrySet AcntID CurrencyPrec TagID Rational (Either Double (EntryValue Rational))) resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do m <- askDBState kmCurrency cur <- liftInner $ resolveCurrency m r tsgCurrency @@ -356,7 +356,7 @@ resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do let valRes = liftInner $ fmap (roundPrecisionCur cur) <$> resolveValue r tsgValue liftInner $ combineError3 fromRes toRes valRes $ \f t v -> EntrySet - { esTotalValue = v + { esTotalValue = Right v , esCurrency = cur , esFrom = f , esTo = t