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) ->
{ 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

View File

@ -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)

View File

@ -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

View File

@ -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

View File

@ -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)

View File

@ -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