WIP unify history and budget pipelines

This commit is contained in:
Nathan Dwarshuis 2023-06-30 23:54:39 -04:00
parent cc0699eb4e
commit 1ae670187a
6 changed files with 270 additions and 283 deletions

View File

@ -681,39 +681,6 @@ let Amount =
\(v : Type) -> \(v : Type) ->
{ amtWhen : w, amtValue : v, amtDesc : Text } { 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 = let TransferType =
{- {-
The type of a budget transfer. The type of a budget transfer.
@ -1077,7 +1044,7 @@ let ShadowTransfer =
{- {-
Currency of this transfer. Currency of this transfer.
-} -}
TransferCurrency CurID
, stDesc : , stDesc :
{- {-
Description of this transfer. Description of this transfer.
@ -1103,7 +1070,7 @@ let BudgetTransfer =
{- {-
A manually specified transaction for a budget A manually specified transaction for a budget
-} -}
Transfer TaggedAcnt TransferCurrency DatePat TransferValue.Type Transfer TaggedAcnt CurID DatePat TransferValue.Type
let Budget = let Budget =
{- {-
@ -1173,8 +1140,6 @@ in { CurID
, TransferMatcher , TransferMatcher
, ShadowTransfer , ShadowTransfer
, AcntSet , AcntSet
, TransferCurrency
, Exchange
, TaggedAcnt , TaggedAcnt
, AccountTree , AccountTree
, Account , Account

View File

@ -4,6 +4,7 @@ import Control.Monad.Except
import Data.Foldable import Data.Foldable
import Database.Persist.Monad import Database.Persist.Monad
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)
@ -44,9 +45,9 @@ insertBudget
let res1 = mapErrors (insertIncome key bgtLabel intAllos bgtInterval) bgtIncomes let res1 = mapErrors (insertIncome key bgtLabel intAllos bgtInterval) bgtIncomes
let res2 = expandTransfers key bgtLabel bgtInterval bgtTransfers let res2 = expandTransfers key bgtLabel bgtInterval bgtTransfers
txs <- combineError (concat <$> res1) res2 (++) txs <- combineError (concat <$> res1) res2 (++)
m <- askDBState kmCurrency shadow <- addShadowTransfers bgtShadowTransfers txs
shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs (_, toIns) <- balanceTxs $ fmap ToInsert $ txs ++ shadow
void $ mapErrors insertBudgetTx $ balanceTransfers $ txs ++ shadow void $ insertBudgetTx toIns
where where
acntRes = mapErrors isNotIncomeAcnt alloAcnts acntRes = mapErrors isNotIncomeAcnt alloAcnts
intAlloRes = combineError3 pre_ tax_ post_ (,,) intAlloRes = combineError3 pre_ tax_ post_ (,,)
@ -61,69 +62,94 @@ insertBudget
-- TODO need to systematically make this function match the history version, -- TODO need to systematically make this function match the history version,
-- which will allow me to use the same balancing algorithm for both -- which will allow me to use the same balancing algorithm for both
balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer] -- balanceTransfers :: [Tx BudgetMeta] -> [KeyEntry]
balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen -- balanceTransfers = undefined
where
go bals f@FlatTransfer {ftFrom, ftTo, ftValue = UnbalancedValue {cvValue, cvType}} = -- balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen
let balTo = M.findWithDefault 0 ftTo bals -- where
x = amtToMove balTo cvType cvValue -- go bals f@FlatTransfer {ftFrom, ftTo, ftValue = UnbalancedValue {cvValue, cvType}} =
bals' = mapAdd_ ftTo x $ mapAdd_ ftFrom (-x) bals -- let balTo = M.findWithDefault 0 ftTo bals
in (bals', f {ftValue = x}) -- x = amtToMove balTo cvType cvValue
-- TODO might need to query signs to make this intuitive; as it is this will -- bals' = mapAdd_ ftTo x $ mapAdd_ ftFrom (-x) bals
-- probably work, but for credit accounts I might need to supply a negative -- in (bals', f {ftValue = x})
-- target value -- -- TODO might need to query signs to make this intuitive; as it is this will
amtToMove _ BTFixed x = x -- -- probably work, but for credit accounts I might need to supply a negative
amtToMove bal BTPercent x = -(x / 100 * bal) -- -- target value
amtToMove bal BTTarget x = x - bal -- amtToMove _ TFixed x = x
-- amtToMove bal TPercent x = -(x / 100 * bal)
-- amtToMove bal TBalance x = x - bal
insertBudgetTx insertBudgetTx
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> BalancedTransfer => [InsertTx BudgetMeta]
-> m () -> m ()
insertBudgetTx FlatTransfer {ftFrom, ftTo, ftMeta, ftCur, ftValue, ftDesc, ftWhen} = do insertBudgetTx toInsert = do
((sFrom, sTo), exchange) <- entryPair ftFrom ftTo ftCur ftValue forM_ (groupKey (commitRHash . bmCommit) $ (\x -> (itxCommit x, x)) <$> toInsert) $
insertPair sFrom sTo \(c, ts) -> do
forM_ exchange $ uncurry insertPair ck <- insert $ bmCommit c
mapM_ (insertTx ck) ts
where where
insertPair from to = do insertTx c InsertTx {itxDate = d, itxDescr = e, itxEntries = ss, itxCommit = BudgetMeta {bmName}} = do
k <- insert $ TransactionR (bmCommit ftMeta) ftWhen ftDesc let anyDeferred = any (isJust . feDeferred) ss
insertBudgetLabel k from k <- insert $ TransactionR c d e anyDeferred
insertBudgetLabel k to mapM_ (insertBudgetLabel bmName k) ss
insertBudgetLabel k entry = do insertBudgetLabel n k entry = do
sk <- insertEntry k entry 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 entryPair
:: (MonadInsertError m, MonadFinance m) :: (MonadInsertError m, MonadFinance m)
=> TaggedAcnt => TaggedAcnt
-> TaggedAcnt -> TaggedAcnt
-> BudgetCurrency -> CurID
-> Rational -> T.Text
-> m (EntryPair, Maybe EntryPair) -> Double
entryPair from to cur val = case cur of -> m (EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational))
NoX curid -> (,Nothing) <$> pair curid from to val entryPair = entryPair_ (fmap (EntryValue TFixed) . roundPrecisionCur)
X Exchange {xFromCur, xToCur, xAcnt, xRate} -> do
let middle = TaggedAcnt xAcnt [] entryPair_
let res1 = pair xFromCur from middle val :: (MonadInsertError m, MonadFinance m)
let res2 = pair xToCur middle to (val * roundPrecision 3 xRate) => (CurrencyPrec -> v -> v')
combineError res1 res2 $ \a b -> (a, Just b) -> 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 where
pair curid from_ to_ v = do halfEntry :: a -> [t] -> HalfEntrySet a c t v
let s1 = entry curid from_ (-v) halfEntry a ts =
let s2 = entry curid to_ v HalfEntrySet
combineError s1 s2 (,) { hesPrimary = Entry {eAcnt = a, eValue = (), eComment = com, eTags = ts}
entry c TaggedAcnt {taAcnt, taTags} v = , hesOther = []
resolveEntry $ }
FullEntry pair cp (TaggedAcnt fa fts) (TaggedAcnt ta tts) v =
{ feCurrency = c EntrySet
, feEntry = { esCurrency = cp
Entry , esTotalValue = v
{ eAcnt = taAcnt , esFrom = halfEntry fa fts
, eValue = v , esTo = halfEntry ta tts
, eComment = "" }
, eTags = taTags
}
}
sortAllo :: MultiAllocation v -> InsertExcept (DaySpanAllocation v) sortAllo :: MultiAllocation v -> InsertExcept (DaySpanAllocation v)
sortAllo a@Allocation {alloAmts = as} = do sortAllo a@Allocation {alloAmts = as} = do
@ -151,7 +177,7 @@ insertIncome
-> IntAllocations -> IntAllocations
-> Maybe Interval -> Maybe Interval
-> Income -> Income
-> m [UnbalancedTransfer] -> m [Tx BudgetMeta]
insertIncome insertIncome
key key
name name
@ -197,27 +223,34 @@ insertIncome
let (preDeductions, pre) = let (preDeductions, pre) =
allocatePre precision gross $ allocatePre precision gross $
flatPre ++ concatMap (selectAllos day) intPre flatPre ++ concatMap (selectAllos day) intPre
tax = let tax =
allocateTax precision gross preDeductions scaler $ allocateTax precision gross preDeductions scaler $
flatTax ++ concatMap (selectAllos day) intTax flatTax ++ concatMap (selectAllos day) intTax
aftertaxGross = gross - sumAllos (tax ++ pre) aftertaxGross = gross - sumAllos (tax ++ pre)
post = let post =
allocatePost precision aftertaxGross $ allocatePost precision aftertaxGross $
flatPost ++ concatMap (selectAllos day) intPost flatPost ++ concatMap (selectAllos day) intPost
balance = aftertaxGross - sumAllos post let balance = aftertaxGross - sumAllos post
bal = -- TODO double or rational here?
FlatTransfer primary <-
{ ftMeta = meta entryPair
, ftWhen = day incFrom
, ftFrom = incFrom incToBal
, ftCur = NoX incCurrency incCurrency
, ftTo = incToBal "balance after deductions"
, ftValue = UnbalancedValue BTFixed balance (fromRational balance)
, ftDesc = "balance after deductions" 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 if balance < 0
then throwError $ InsertException [IncomeError day name balance] then throwError $ InsertException [IncomeError day name balance]
else return (bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post)) else return (bal : allos)
periodScaler periodScaler
:: PeriodType :: PeriodType
@ -298,7 +331,7 @@ flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts
where where
go Amount {amtValue, amtDesc} = go Amount {amtValue, amtDesc} =
FlatAllocation FlatAllocation
{ faCur = NoX alloCur { faCur = alloCur
, faTo = alloTo , faTo = alloTo
, faValue = amtValue , faValue = amtValue
, faDesc = amtDesc , faDesc = amtDesc
@ -311,28 +344,30 @@ selectAllos day Allocation {alloAmts, alloCur, alloTo} =
where where
go Amount {amtValue, amtDesc} = go Amount {amtValue, amtDesc} =
FlatAllocation FlatAllocation
{ faCur = NoX alloCur { faCur = alloCur
, faTo = alloTo , faTo = alloTo
, faValue = amtValue , faValue = amtValue
, faDesc = amtDesc , faDesc = amtDesc
} }
allo2Trans allo2Trans
:: BudgetMeta :: (MonadInsertError m, MonadFinance m)
=> BudgetMeta
-> Day -> Day
-> TaggedAcnt -> TaggedAcnt
-> FlatAllocation Rational -> FlatAllocation Rational
-> UnbalancedTransfer -> m (Tx BudgetMeta)
allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} = allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} = do
FlatTransfer -- TODO double here?
{ ftMeta = meta p <- entryPair from faTo faCur faDesc (fromRational faValue)
, ftWhen = day return
, ftFrom = from Tx
, ftCur = faCur { txCommit = meta
, ftTo = faTo , txDate = day
, ftValue = UnbalancedValue BTFixed faValue , txPrimary = p
, ftDesc = faDesc , txOther = []
} , txDescr = faDesc
}
allocatePre allocatePre
:: Natural :: Natural
@ -411,46 +446,43 @@ expandTransfers
-> T.Text -> T.Text
-> Maybe Interval -> Maybe Interval
-> [BudgetTransfer] -> [BudgetTransfer]
-> m [UnbalancedTransfer] -> m [Tx BudgetMeta]
expandTransfers key name localInterval ts = do expandTransfers key name localInterval ts = do
txs <- txs <-
fmap (L.sortOn ftWhen . concat) $ fmap (L.sortOn txDate . concat) $
combineErrors $ combineErrors $
fmap (expandTransfer key name) ts fmap (expandTransfer key name) ts
case localInterval of case localInterval of
Nothing -> return txs Nothing -> return txs
Just i -> do Just i -> do
bounds <- liftExcept $ resolveDaySpan i bounds <- liftExcept $ resolveDaySpan i
return $ filter (inDaySpan bounds . ftWhen) txs return $ filter (inDaySpan bounds . txDate) txs
expandTransfer expandTransfer
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> CommitRId => CommitRId
-> T.Text -> T.Text
-> BudgetTransfer -> BudgetTransfer
-> m [UnbalancedTransfer] -> m [Tx BudgetMeta]
expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = do expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = do
precision <- lookupCurrencyPrec $ initialCurrency transCurrency fmap concat $ mapErrors go transAmounts
fmap concat $ combineErrors $ fmap (go precision) transAmounts
where where
go go
precision
Amount Amount
{ amtWhen = pat { amtWhen = pat
, amtValue = BudgetTransferValue {btVal = v, btType = y} , amtValue = TransferValue {tvVal = v, tvType = t}
, amtDesc = desc , amtDesc = desc
} = } =
withDates pat $ \day -> do withDates pat $ \day -> do
let meta = BudgetMeta {bmCommit = key, bmName = name} let meta = BudgetMeta {bmCommit = key, bmName = name}
p <- entryPair_ (\_ x -> EntryValue t $ toRational x) transFrom transTo transCurrency desc v
return return
FlatTransfer Tx
{ ftMeta = meta { txCommit = meta
, ftWhen = day , txDate = day
, ftCur = transCurrency , txPrimary = p
, ftFrom = transFrom , txOther = []
, ftTo = transTo , txDescr = desc
, ftValue = UnbalancedValue y $ roundPrecision precision v
, ftDesc = desc
} }
withDates withDates
@ -468,63 +500,53 @@ withDates dp f = do
-- TODO this is going to be O(n*m), which might be a problem? -- TODO this is going to be O(n*m), which might be a problem?
addShadowTransfers addShadowTransfers
:: CurrencyMap :: (MonadInsertError m, MonadFinance m)
-> [ShadowTransfer] => [ShadowTransfer]
-> [UnbalancedTransfer] -> [Tx BudgetMeta]
-> InsertExcept [UnbalancedTransfer] -> m [Tx BudgetMeta]
addShadowTransfers cm ms txs = addShadowTransfers ms txs = mapErrors go txs
fmap catMaybes $ where
combineErrors $ go tx = do
fmap (uncurry (fromShadow cm)) $ es <- catMaybes <$> mapErrors (fromShadow tx) ms
[(t, m) | t <- txs, m <- ms] return $ tx {txOther = es}
fromShadow fromShadow
:: CurrencyMap :: (MonadInsertError m, MonadFinance m)
-> UnbalancedTransfer => Tx BudgetMeta
-> ShadowTransfer -> ShadowTransfer
-> InsertExcept (Maybe UnbalancedTransfer) -> m (Maybe (EntrySet AcntID CurrencyPrec TagID Rational (Either Double (EntryValue Rational))))
fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} = do
res <- shadowMatches (stMatch t) tx res <- liftExcept $ shadowMatches stMatch tx
v <- roundPrecisionCur (initialCurrency stCurrency) cm stRatio es <- entryPair_ (\_ v -> Left v) stFrom stTo stCurrency stDesc stRatio
return $ return $ if not res then Nothing else Just es
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
}
shadowMatches :: TransferMatcher -> UnbalancedTransfer -> InsertExcept Bool shadowMatches :: TransferMatcher -> Tx BudgetMeta -> InsertExcept Bool
shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do shadowMatches TransferMatcher {tmFrom, tmTo, tmDate} Tx {txPrimary, txDate} = do
valRes <- valMatches tmVal $ cvValue $ ftValue tx -- 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 $ return $
memberMaybe (taAcnt $ ftFrom tx) tmFrom memberMaybe (eAcnt $ hesPrimary $ esFrom txPrimary) tmFrom
&& memberMaybe (taAcnt $ ftTo tx) tmTo && memberMaybe (eAcnt $ hesPrimary $ esTo txPrimary) tmTo
&& maybe True (`dateMatches` ftWhen tx) tmDate && maybe True (`dateMatches` txDate) tmDate
&& valRes
where where
-- && valRes
memberMaybe x AcntSet {asList, asInclude} = memberMaybe x AcntSet {asList, asInclude} =
(if asInclude then id else not) $ x `elem` asList (if asInclude then id else not) $ x `elem` asList
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- random -- random
initialCurrency :: BudgetCurrency -> CurID -- initialCurrency :: TransferCurrency -> CurID
initialCurrency (NoX c) = c -- initialCurrency (NoX c) = c
initialCurrency (X Exchange {xFromCur = c}) = c -- initialCurrency (X Exchange {xFromCur = c}) = c
alloAcnt :: Allocation w v -> AcntID alloAcnt :: Allocation w v -> AcntID
alloAcnt = taAcnt . alloTo alloAcnt = taAcnt . alloTo
data UnbalancedValue = UnbalancedValue data UnbalancedValue = UnbalancedValue
{ cvType :: !BudgetTransferType { cvType :: !TransferType
, cvValue :: !Rational , cvValue :: !Rational
} }
deriving (Show) deriving (Show)
@ -533,75 +555,77 @@ data UnbalancedValue = UnbalancedValue
-- in the history algorithm, which will entail resolving the budget currency -- in the history algorithm, which will entail resolving the budget currency
-- stuff earlier in the chain, and preloading multiple entries into this thing -- stuff earlier in the chain, and preloading multiple entries into this thing
-- before balancing. -- before balancing.
type UnbalancedTransfer = FlatTransfer UnbalancedValue -- type UnbalancedTransfer = FlatTransfer UnbalancedValue
ubt2tx :: UnbalancedTransfer -> Tx [EntrySet AcntID CurID TagID Rational] BudgetMeta -- ubt2tx :: UnbalancedTransfer -> Tx BudgetMeta
ubt2tx -- ubt2tx
FlatTransfer -- FlatTransfer
{ ftFrom -- { ftFrom
, ftTo -- , ftTo
, ftValue -- , ftValue
, ftWhen -- , ftWhen
, ftDesc -- , ftDesc
, ftMeta -- , ftMeta
, ftCur -- , ftCur
} = -- } =
Tx -- Tx
{ txDescr = ftDesc -- { txDescr = ftDesc
, txDate = ftWhen -- , txDate = ftWhen
, txEntries = entries ftCur -- , txPrimary = p
, txCommit = ftMeta -- , txOther = maybeToList os
} -- , txCommit = ftMeta
where -- }
entries (NoX curid) = [pair curid ftFrom ftTo ftValue] -- where
entries (X Exchange {xFromCur, xToCur, xAcnt, xRate}) = -- (p, os) = entries ftCur
let middle = TaggedAcnt xAcnt [] -- entries (NoX curid) = (pair curid ftFrom ftTo ftValue, Nothing)
p1 = pair xFromCur ftFrom middle ftValue -- entries (X Exchange {xFromCur, xToCur, xAcnt, xRate}) =
p2 = pair xToCur middle ftTo (ftValue * roundPrecision 3 xRate) -- let middle = TaggedAcnt xAcnt []
in [p1, p2] -- p1 = pair xFromCur ftFrom middle ftValue
pair c (TaggedAcnt fa fts) (TaggedAcnt ta tts) v = -- p2 = pair xToCur middle ftTo (ftValue * roundPrecision 3 xRate)
EntrySet -- in (p1, Just p2)
{ esTotalValue = v -- pair c (TaggedAcnt fa fts) (TaggedAcnt ta tts) v =
, esCurrency = c -- EntrySet
, esFrom = -- { esTotalValue = v
HalfEntrySet -- , esCurrency = c
{ hesPrimary = -- , esFrom =
Entry -- HalfEntrySet
{ eValue = () -- { hesPrimary =
, eComment = "" -- Entry
, eAcnt = fa -- { eValue = ()
, eTags = fts -- , eComment = ""
} -- , eAcnt = fa
, hesOther = [] -- , eTags = fts
} -- }
, esTo = -- , hesOther = []
HalfEntrySet -- }
{ hesPrimary = -- , esTo =
Entry -- HalfEntrySet
{ eValue = () -- { hesPrimary =
, eComment = "" -- Entry
, eAcnt = ta -- { eValue = ()
, eTags = tts -- , eComment = ""
} -- , eAcnt = ta
, hesOther = [] -- , eTags = tts
} -- }
} -- , hesOther = []
-- }
-- }
type BalancedTransfer = FlatTransfer Rational -- type BalancedTransfer = FlatTransfer Rational
data FlatTransfer v = FlatTransfer -- data FlatTransfer v = FlatTransfer
{ ftFrom :: !TaggedAcnt -- { ftFrom :: !TaggedAcnt
, ftTo :: !TaggedAcnt -- , ftTo :: !TaggedAcnt
, ftValue :: !v -- , ftValue :: !v
, ftWhen :: !Day -- , ftWhen :: !Day
, ftDesc :: !T.Text -- , ftDesc :: !T.Text
, ftMeta :: !BudgetMeta -- , ftMeta :: !BudgetMeta
, ftCur :: !BudgetCurrency -- , ftCur :: !TransferCurrency
} -- }
deriving (Show) -- deriving (Show)
data BudgetMeta = BudgetMeta data BudgetMeta = BudgetMeta
{ bmCommit :: !CommitRId { bmCommit :: !CommitR
, bmName :: !T.Text , bmName :: !T.Text
} }
deriving (Show) deriving (Show)
@ -622,6 +646,6 @@ data FlatAllocation v = FlatAllocation
{ faValue :: !v { faValue :: !v
, faDesc :: !T.Text , faDesc :: !T.Text
, faTo :: !TaggedAcnt , faTo :: !TaggedAcnt
, faCur :: !BudgetCurrency , faCur :: !CurID
} }
deriving (Functor, Show) deriving (Functor, Show)

View File

@ -3,6 +3,7 @@ module Internal.History
, readHistTransfer , readHistTransfer
, insertHistory , insertHistory
, splitHistory , splitHistory
, balanceTxs
) )
where where
@ -75,7 +76,7 @@ splitHistory = partitionEithers . fmap go
insertHistory insertHistory
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> [EntryBin] => [EntryBin CommitR]
-> m () -> m ()
insertHistory hs = do insertHistory hs = do
(toUpdate, toInsert) <- balanceTxs hs (toUpdate, toInsert) <- balanceTxs hs
@ -95,17 +96,17 @@ txPair
-> AcntID -> AcntID
-> AcntID -> AcntID
-> CurrencyPrec -> CurrencyPrec
-> Double -> TransferValue
-> T.Text -> T.Text
-> Tx CommitR -> Tx CommitR
txPair commit day from to cur val desc = txPair commit day from to cur (TransferValue t v) desc =
Tx Tx
{ txDescr = desc { txDescr = desc
, txDate = day , txDate = day
, txCommit = commit , txCommit = commit
, txPrimary = , txPrimary =
EntrySet EntrySet
{ esTotalValue = -(roundPrecisionCur cur val) { esTotalValue = EntryValue t $ toRational v
, esCurrency = cur , esCurrency = cur
, esFrom = HalfEntrySet {hesPrimary = entry from, hesOther = []} , esFrom = HalfEntrySet {hesPrimary = entry from, hesOther = []}
, esTo = HalfEntrySet {hesPrimary = entry to, hesOther = []} , esTo = HalfEntrySet {hesPrimary = entry to, hesOther = []}
@ -125,7 +126,7 @@ txPair commit day from to cur val desc =
-- resolveTx t@Tx {txEntries = ss} = -- resolveTx t@Tx {txEntries = ss} =
-- (\kss -> t {txEntries = kss}) <$> mapErrors resolveEntry 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 insertTx c InsertTx {itxDate = d, itxDescr = e, itxEntries = ss} = do
let anyDeferred = any (isJust . feDeferred) ss let anyDeferred = any (isJust . feDeferred) ss
k <- insert $ TransactionR c d e anyDeferred k <- insert $ TransactionR c d e anyDeferred
@ -348,8 +349,8 @@ matchNonDates ms = go ([], [], initZipper ms)
balanceTxs balanceTxs
:: (MonadInsertError m, MonadFinance m) :: (MonadInsertError m, MonadFinance m)
=> [EntryBin] => [EntryBin a]
-> m ([UEBalanced], [InsertTx]) -> m ([UEBalanced], [InsertTx a])
balanceTxs ebs = balanceTxs ebs =
first concat . partitionEithers . catMaybes first concat . partitionEithers . catMaybes
<$> evalStateT (mapErrors go $ L.sortOn binDate ebs) M.empty <$> evalStateT (mapErrors go $ L.sortOn binDate ebs) M.empty
@ -358,22 +359,27 @@ balanceTxs ebs =
go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do
modify $ mapAdd_ (reAcnt, reCurrency) reValue modify $ mapAdd_ (reAcnt, reCurrency) reValue
return Nothing return Nothing
go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate}) = go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate}) = do
let res0 = balanceEntrySet (\_ _ v -> return v) txPrimary e <- balanceEntrySet primaryBalance txPrimary
resN = mapErrors (balanceEntrySet primaryBalance) txOther -- TODO this logic is really stupid, I'm balancing the total twice; fix
in combineError res0 resN $ \e es -> -- will likely entail making a separate data structure for txs derived
-- TODO repacking a Tx into almost the same record seems stupid -- from transfers vs statements
Just $ let etot = sum $ eValue . feEntry <$> filter ((< 0) . feIndex) e
Right $ es <- mapErrors (balanceEntrySet (secondaryBalance etot)) txOther
InsertTx let tx =
{ itxDescr = txDescr InsertTx
, itxDate = txDate { itxDescr = txDescr
, itxEntries = concat $ e : es , itxDate = txDate
, itxCommit = txCommit , itxEntries = concat $ e : es
} , itxCommit = txCommit
}
return $ Just $ Right tx
primaryBalance Entry {eAcnt} c (EntryValue t v) = findBalance eAcnt c t v 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 (ToUpdate UpdateEntrySet {utDate}) = utDate
binDate (ToRead ReadEntry {reDate}) = reDate binDate (ToRead ReadEntry {reDate}) = reDate
binDate (ToInsert Tx {txDate}) = txDate binDate (ToInsert Tx {txDate}) = txDate

View File

@ -34,7 +34,6 @@ makeHaskellTypesWith
, MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher" , MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher"
, MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter" , MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter"
, MultipleConstructors "LinkedEntryNumGetter" "(./dhall/Types.dhall).LinkedEntryNumGetter" , MultipleConstructors "LinkedEntryNumGetter" "(./dhall/Types.dhall).LinkedEntryNumGetter"
, MultipleConstructors "TransferCurrency" "(./dhall/Types.dhall).TransferCurrency"
, MultipleConstructors "TransferType" "(./dhall/Types.dhall).TransferType" , MultipleConstructors "TransferType" "(./dhall/Types.dhall).TransferType"
, MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod" , MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod"
, MultipleConstructors "PeriodType" "(./dhall/Types.dhall).PeriodType" , MultipleConstructors "PeriodType" "(./dhall/Types.dhall).PeriodType"
@ -55,8 +54,7 @@ makeHaskellTypesWith
, SingleConstructor "TransferMatcher" "TransferMatcher" "(./dhall/Types.dhall).TransferMatcher.Type" , SingleConstructor "TransferMatcher" "TransferMatcher" "(./dhall/Types.dhall).TransferMatcher.Type"
, SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer" , SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer"
, -- , SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income.Type" , -- , 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 "Entry" "Entry" "(./dhall/Types.dhall).Entry"
, SingleConstructor "PretaxValue" "PretaxValue" "(./dhall/Types.dhall).PretaxValue" , SingleConstructor "PretaxValue" "PretaxValue" "(./dhall/Types.dhall).PretaxValue"
, SingleConstructor "TaxBracket" "TaxBracket" "(./dhall/Types.dhall).TaxBracket" , SingleConstructor "TaxBracket" "TaxBracket" "(./dhall/Types.dhall).TaxBracket"
@ -97,8 +95,6 @@ deriveProduct
, "DateMatcher" , "DateMatcher"
, "ValMatcher" , "ValMatcher"
, "YMDMatcher" , "YMDMatcher"
, "TransferCurrency"
, "Exchange"
, "EntryNumGetter" , "EntryNumGetter"
, "LinkedNumGetter" , "LinkedNumGetter"
, "LinkedEntryNumGetter" , "LinkedEntryNumGetter"
@ -183,7 +179,7 @@ deriving instance Ord DatePat
deriving instance Hashable DatePat deriving instance Hashable DatePat
type BudgetTransfer = type BudgetTransfer =
Transfer TaggedAcnt TransferCurrency DatePat TransferValue Transfer TaggedAcnt CurID DatePat TransferValue
deriving instance Hashable BudgetTransfer 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 (Eq w, Eq v) => Eq (Amount w v)
deriving instance Hashable Exchange
deriving instance Hashable TransferCurrency
data Allocation w v = Allocation data Allocation w v = Allocation
{ alloTo :: TaggedAcnt { alloTo :: TaggedAcnt
, alloAmts :: [Amount w v] , alloAmts :: [Amount w v]
@ -428,7 +420,7 @@ type AcntID = T.Text
type TagID = T.Text type TagID = T.Text
type HistTransfer = Transfer AcntID CurID DatePat Double type HistTransfer = Transfer AcntID CurID DatePat TransferValue
deriving instance Generic HistTransfer deriving instance Generic HistTransfer

View File

@ -121,10 +121,10 @@ data UpdateEntrySet = UpdateEntrySet
, utTotalValue :: !Rational , utTotalValue :: !Rational
} }
data EntryBin data EntryBin a
= ToUpdate UpdateEntrySet = ToUpdate UpdateEntrySet
| ToRead ReadEntry | ToRead ReadEntry
| ToInsert (Tx CommitR) | ToInsert (Tx a)
data InsertEntry a c t = InsertEntry data InsertEntry a c t = InsertEntry
{ feCurrency :: !c { feCurrency :: !c
@ -221,17 +221,17 @@ data EntrySet a c t v v' = EntrySet
data Tx k = Tx data Tx k = Tx
{ txDescr :: !T.Text { txDescr :: !T.Text
, txDate :: !Day , txDate :: !Day
, txPrimary :: !(EntrySet AcntID CurrencyPrec TagID Rational Rational) , txPrimary :: !(EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational))
, txOther :: ![EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational)] , txOther :: ![EntrySet AcntID CurrencyPrec TagID Rational (Either Double (EntryValue Rational))]
, txCommit :: !k , txCommit :: !k
} }
deriving (Generic) deriving (Generic)
data InsertTx = InsertTx data InsertTx a = InsertTx
{ itxDescr :: !T.Text { itxDescr :: !T.Text
, itxDate :: !Day , itxDate :: !Day
, itxEntries :: ![InsertEntry AccountRId CurrencyRId TagRId] , itxEntries :: ![InsertEntry AccountRId CurrencyRId TagRId]
, itxCommit :: !CommitR , itxCommit :: !a
} }
deriving (Generic) deriving (Generic)

View File

@ -327,7 +327,7 @@ toTx
, txCommit = () , txCommit = ()
, txPrimary = , txPrimary =
EntrySet EntrySet
{ esTotalValue = roundPrecisionCur cur $ tgScale * fromRational trAmount { esTotalValue = EntryValue TFixed $ roundPrecisionCur cur $ tgScale * fromRational trAmount
, esCurrency = cur , esCurrency = cur
, esFrom = f , esFrom = f
, esTo = t , esTo = t
@ -347,7 +347,7 @@ resolveSubGetter
:: MonadFinance m :: MonadFinance m
=> TxRecord => TxRecord
-> TxSubGetter -> 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 resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
m <- askDBState kmCurrency m <- askDBState kmCurrency
cur <- liftInner $ resolveCurrency m r tsgCurrency 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 let valRes = liftInner $ fmap (roundPrecisionCur cur) <$> resolveValue r tsgValue
liftInner $ combineError3 fromRes toRes valRes $ \f t v -> liftInner $ combineError3 fromRes toRes valRes $ \f t v ->
EntrySet EntrySet
{ esTotalValue = v { esTotalValue = Right v
, esCurrency = cur , esCurrency = cur
, esFrom = f , esFrom = f
, esTo = t , esTo = t