WIP unify history and budget pipelines
This commit is contained in:
parent
cc0699eb4e
commit
1ae670187a
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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,68 +62,93 @@ 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)
|
||||
|
|
@ -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
|
||||
if balance < 0
|
||||
then throwError $ InsertException [IncomeError day name balance]
|
||||
else return (bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post))
|
||||
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,27 +344,29 @@ 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
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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 $
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue