WIP unify history and budget pipelines
This commit is contained in:
parent
cc0699eb4e
commit
1ae670187a
|
@ -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
|
||||||
|
|
|
@ -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,68 +62,93 @@ 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
|
|
||||||
{ feCurrency = c
|
|
||||||
, feEntry =
|
|
||||||
Entry
|
|
||||||
{ eAcnt = taAcnt
|
|
||||||
, eValue = v
|
|
||||||
, eComment = ""
|
|
||||||
, eTags = taTags
|
|
||||||
}
|
}
|
||||||
|
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 :: MultiAllocation v -> InsertExcept (DaySpanAllocation v)
|
||||||
|
@ -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,27 +344,29 @@ 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
|
||||||
|
@ -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)
|
||||||
|
|
|
@ -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
|
||||||
|
let tx =
|
||||||
InsertTx
|
InsertTx
|
||||||
{ itxDescr = txDescr
|
{ itxDescr = txDescr
|
||||||
, itxDate = txDate
|
, itxDate = txDate
|
||||||
, itxEntries = concat $ e : es
|
, itxEntries = concat $ e : es
|
||||||
, itxCommit = txCommit
|
, 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
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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)
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in New Issue