ADD linked credit entries

This commit is contained in:
Nathan Dwarshuis 2023-06-19 12:14:18 -04:00
parent c2525fb77c
commit 03e75ce549
6 changed files with 361 additions and 262 deletions

View File

@ -411,6 +411,35 @@ let EntryNumGetter =
| BalanceN : Double
>
let LinkedNumGetter =
{-
Means to get a numeric value from another entry
-}
{ Type =
{ lngIndex :
{-
Index of the entry to link.
-}
Natural
, lngScale :
{-
Factor by which to multiply the value of the linked entry.
-}
Double
}
, default = { lngScale = 1, lngIndex = 0 }
}
let LinkedEntryNumGetter =
{-
Means to get a numeric value from a statement row or another entry getter.
Linked: a number referring to the entry on the 'from' side of the
transaction (with 0 being the primary entry)
Getter: a normal getter
-}
< Linked : LinkedNumGetter.Type | Getter : EntryNumGetter >
let EntryTextGetter =
{-
Means to get a textual value from a statement row.
@ -473,115 +502,100 @@ let Entry =
let EntryGetter =
{-
Means for getting an entry from a given row in a statement
Means for getting an entry from a given row in a statement (debit side)
-}
{ Type = Entry EntryAcntGetter EntryNumGetter TagID
\(n : Type) ->
{ Type = Entry EntryAcntGetter n TagID
, default = { eComment = "", eTags = [] : List TagID }
}
let FromEntryGetter =
{-
Means for getting an entry from a given row in a statement (debit side)
-}
EntryGetter EntryNumGetter
let ToEntryGetter =
{-
Means for getting an entry from a given row in a statement (credit side)
-}
EntryGetter LinkedEntryNumGetter
let TxHalfGetter =
{-
Means of transforming one row in a statement to either the credit or debit
half of a transaction
-}
\(e : Type) ->
{ Type =
{ thgAcnt :
{-
Account from which this transaction will be balanced. The value
of the transaction will be assigned to this account unless
other entries are specified (see below).
This account (and its associated entry) will be denoted
'primary'.
-}
EntryAcntGetter
, thgEntries :
{-
Means of getting additional entries from which this transaction
will be balanced. If this list is empty, the total value of the
transaction will be assigned to the value defined by 'tsgAcnt'.
Otherwise, the entries specified here will be added to this side
of this transaction, and their sum value will be subtracted from
the total value of the transaction and assigned to 'tsgAcnt'.
This is useful for situations where a particular transaction
denotes values that come from multiple subaccounts.
-}
List e
, thgComment :
{-
Comment for the primary entry
-}
Text
, thgTags :
{-
Tags for the primary entry
-}
List TagID
}
, default =
{ thgTags = [] : List TagID
, thgComment = ""
, thgEntries = [] : List e
}
}
let TxSubGetter =
{-
A means for transforming one row in a statement to a transaction
-}
{ Type =
{ tsgFromAcnt : EntryAcntGetter
, tsgToAcnt : EntryAcntGetter
, tsgValue : EntryNumGetter
{ tsgValue : EntryNumGetter
, tsgCurrency : EntryCurGetter
, tsgFromEntries : List EntryGetter.Type
, tsgFromComment : Text
, tsgToComment : Text
, tsgFromTags : List TagID
, tsgToTags : List TagID
, tsgToEntries : List EntryGetter.Type
}
, default =
{ tsgFromTags = [] : List TagID
, tsgToTags = [] : List TagID
, tsgFromComment = ""
, tsgToComment = ""
, tsgFromEntries = [] : List EntryGetter.Type
, tsgToEntries = [] : List EntryGetter.Type
, tsgFrom : (TxHalfGetter FromEntryGetter.Type).Type
, tsgTo : (TxHalfGetter ToEntryGetter.Type).Type
}
, default = { tsgFrom = TxHalfGetter, tsgTo = TxHalfGetter }
}
let TxGetter =
{-
A means for transforming one row in a statement to a transaction
At least two entries must be made for any given transaction. Below these
correspond to the 'from' and 'to' accounts, which will share a single value
(whose positive is added to 'to' and negative is added to 'from' accounts)
given by the record (ie one row in a statement) denominated in the given
currency.
Optionally, both sides of the from/to flow of value can be split with other
accounts (given by 'tgFromEntries' and 'tgToEntries'). In either case, the
amount actually transferred between the 'from' and 'to' accounts above
will be the difference after considering these additional account entries.
Furthermore, additionally entries denominated in different currencies
may be specified via 'tgOtherEntries'. Each member in this list corresponds
to a different currency (and associated entries) governed by most of the
rules for this type regarding balancing and splitting value.
-}
{ Type =
{ tgFromAcnt :
{-
Account from which this transaction will be balanced. The value of
the transaction will be assigned to this account unless other from
entries are specified (see below).
-}
EntryAcntGetter
, tgToAcnt :
{-
Account from which this transaction will be balanced. The value of
the transaction will be assigned to this account unless other from
entries are specified (see below).
-}
EntryAcntGetter
, tgFromComment : Text
, tgToComment : Text
, tgFromTags : List TagID
, tgToTags : List TagID
, tgCurrency :
{-
Currency to assign to the account/value denoted by 'tgFromAcnt'
above.
-}
EntryCurGetter
, tgFromEntries :
{-
Means of getting additional entries from which this transaction will
be balanced (minimum 0). If this list is empty, the total value of the
transaction will be assigned to the value defined by 'tgFromAcnt'.
Otherwise, the entries specified here will be added to the credit side
of this transaction, and their sum value will be subtracted from the
total value of the transaction and assigned to 'tgFromAcnt'.
This is useful for situations where a particular transaction denotes
values that come from multiple subaccounts.
-}
List EntryGetter.Type
, tgToEntries :
{-
A means of getting entries for this transaction
-}
List EntryGetter.Type
, tgOtherEntries :
{-
-}
List TxSubGetter.Type
{ tgFrom : (TxHalfGetter FromEntryGetter.Type).Type
, tgTo : (TxHalfGetter ToEntryGetter.Type).Type
, tgCurrency : EntryCurGetter
, tgOtherEntries : List TxSubGetter.Type
}
, default =
{ tgOtherEntries = [] : List TxSubGetter.Type
, tgFromTags = [] : List TagID
, tgToTags = [] : List TagID
, tgFromEntries = [] : List EntryGetter.Type
, tgToEntries = [] : List EntryGetter.Type
, tgFromComment = ""
, tgToComment = ""
, tsgFrom = TxHalfGetter
, tsgTo = TxHalfGetter
}
}
@ -1128,10 +1142,13 @@ in { CurID
, FieldMatcher
, FieldMatcher_
, EntryNumGetter
, LinkedEntryNumGetter
, LinkedNumGetter
, Field
, FieldMap
, Entry
, EntryGetter
, FromEntryGetter
, ToEntryGetter
, EntryTextGetter
, EntryCurGetter
, EntryAcntGetter

View File

@ -7,7 +7,7 @@ let T = ./Types.dhall
let nullEntry =
\(a : T.EntryAcntGetter) ->
\(v : T.EntryNumGetter) ->
T.EntryGetter::{ eAcnt = a, eValue = v }
T.FromEntryGetter::{ eAcnt = a, eValue = v }
let nullOpts = T.TxOpts::{=}
@ -99,7 +99,7 @@ let partN =
(T.EntryNumGetter.ConstN x._2)
// { eComment = x._3 }
in List/map PartEntry T.EntryGetter.Type toEntry ss
in List/map PartEntry T.FromEntryGetter.Type toEntry ss
let addDay =
\(x : T.GregorianM) ->

View File

@ -69,7 +69,7 @@ readHistStmt
readHistStmt root i = whenHash_ CTImport i $ do
bs <- readImport root i
bounds <- askDBState kmStatementInterval
return $ filter (inDaySpan bounds . dtxDate) bs
return $ filter (inDaySpan bounds . txDate) bs
splitHistory :: [History] -> ([HistTransfer], [Statement])
splitHistory = partitionEithers . fmap go
@ -101,16 +101,14 @@ txPair
-> DeferredTx
txPair day from to cur val desc =
Tx
{ dtxDescr = desc
, dtxDate = day
, dtxEntries =
{ txDescr = desc
, txDate = day
, txEntries =
[ EntrySet
{ desTotalValue = -val
, desCurrency = cur
, desFromEntry0 = entry from
, desToEntryBal = entry to
, desFromEntries = []
, desToEntries = []
{ esTotalValue = -val
, esCurrency = cur
, esFrom = HalfEntrySet {hesPrimary = entry from, hesOther = []}
, esTo = HalfEntrySet {hesPrimary = entry to, hesOther = []}
}
]
}
@ -124,11 +122,11 @@ txPair day from to cur val desc =
}
resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx
resolveTx t@Tx {dtxEntries = ss} =
(\kss -> t {dtxEntries = kss}) <$> mapErrors resolveEntry ss
resolveTx t@Tx {txEntries = ss} =
(\kss -> t {txEntries = kss}) <$> mapErrors resolveEntry ss
insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m ()
insertTx c Tx {dtxDate = d, dtxDescr = e, dtxEntries = ss} = do
insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do
k <- insert $ TransactionR c d e
mapM_ (insertEntry k) ss
@ -337,56 +335,75 @@ balanceTxs
=> [(CommitR, DeferredTx)]
-> m [(CommitR, KeyTx)]
balanceTxs ts = do
keyts <- mapErrors resolveTx $ snd $ L.mapAccumL go M.empty ts'
keyts <- mapErrors resolveTx =<< evalStateT (mapM go ts') M.empty
return $ zip cs keyts
where
(cs, ts') = L.unzip $ L.sortOn (dtxDate . snd) ts
go bals t@Tx {dtxEntries} =
second (\es -> t {dtxEntries = concat es}) $
L.mapAccumL balanceEntrySet bals dtxEntries
(cs, ts') = L.unzip $ L.sortOn (txDate . snd) ts
go t@Tx {txEntries} =
(\es -> t {txEntries = concat es}) <$> mapM balanceEntrySet txEntries
type EntryBals = M.Map (AcntID, CurID) Rational
-- TODO might be faster to also do all the key stuff here since currency
-- will be looked up for every entry rather then the entire entry set
balanceEntrySet :: EntryBals -> DeferredEntrySet -> (EntryBals, [BalEntry])
balanceEntrySet
bals
:: (MonadInsertError m, MonadFinance m)
=> DeferredEntrySet
-> StateT EntryBals m [BalEntry]
balanceEntrySet
EntrySet
{ desFromEntry0
, desFromEntries
, desToEntryBal
, desToEntries
, desCurrency
, desTotalValue
} = flipTup $ runState doBalAll bals
{ esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
, esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
, esCurrency
, esTotalValue
} =
do
let (lts, dts) = partitionEithers $ splitLinked <$> ts
fs' <- doEntries fs esTotalValue f0
let fv = V.fromList $ fmap eValue fs'
lts' <- lift $ mapErrors (resolveLinked fv esCurrency) lts
ts' <- doEntries (dts ++ lts') (-esTotalValue) t0
return $ toFull <$> fs' ++ ts'
where
flipTup (a, b) = (b, a)
doEntries es tot e0 = do
es' <- state (\b -> flipTup $ L.mapAccumL (balanceEntry desCurrency) b es)
es' <- liftInnerS $ mapM (balanceEntry esCurrency) es
let val0 = tot - entrySum es'
modify $ mapAdd_ (eAcnt e0, desCurrency) val0
modify $ mapAdd_ (eAcnt e0, esCurrency) val0
return $ e0 {eValue = val0} : es'
doBalAll = do
fes <- doEntries desFromEntries desTotalValue desFromEntry0
tes <- doEntries desToEntries (-desTotalValue) desToEntryBal
return $ toFull <$> fes ++ tes
toFull e = FullEntry {feEntry = e, feCurrency = desCurrency}
toFull e = FullEntry {feEntry = e, feCurrency = esCurrency}
splitLinked e@Entry {eValue} = case eValue of
LinkIndex l -> Left e {eValue = l}
LinkDeferred d -> Right e {eValue = d}
liftInnerS = mapStateT (return . runIdentity)
resolveLinked
:: (MonadInsertError m, MonadFinance m)
=> Vector Rational
-> CurID
-> Entry a LinkedNumGetter t
-> m (Entry a (Deferred Rational) t)
resolveLinked from cur e@Entry {eValue = LinkedNumGetter {lngIndex, lngScale}} = do
curMap <- askDBState kmCurrency
case from V.!? fromIntegral lngIndex of
Nothing -> throwError undefined
Just v -> do
v' <- liftExcept $ roundPrecisionCur cur curMap $ lngScale * fromRational v
return $ e {eValue = Deferred False v'}
entrySum :: Num v => [Entry a v t] -> v
entrySum = sum . fmap eValue
balanceEntry
:: CurID
-> EntryBals
-> Entry AcntID (Deferred Rational) TagID
-> (EntryBals, Entry AcntID Rational TagID)
balanceEntry curID bals e@Entry {eValue = Deferred toBal v, eAcnt} =
(mapAdd_ key newVal bals, e {eValue = newVal})
-> State EntryBals (Entry AcntID Rational TagID)
balanceEntry curID e@Entry {eValue = Deferred toBal v, eAcnt} = do
curBal <- gets (M.findWithDefault 0 key)
let newVal = if toBal then v - curBal else v
modify (mapAdd_ key newVal)
return $ e {eValue = newVal}
where
key = (eAcnt, curID)
curBal = M.findWithDefault 0 key bals
newVal = if toBal then v - curBal else v
-- -- reimplementation from future version :/
-- mapAccumM

View File

@ -33,10 +33,12 @@ makeHaskellTypesWith
, MultipleConstructors "YMDMatcher" "(./dhall/Types.dhall).YMDMatcher"
, MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher"
, MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter"
, MultipleConstructors "LinkedEntryNumGetter" "(./dhall/Types.dhall).LinkedEntryNumGetter"
, MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
, MultipleConstructors "BudgetTransferType" "(./dhall/Types.dhall).BudgetTransferType"
, MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod"
, MultipleConstructors "PeriodType" "(./dhall/Types.dhall).PeriodType"
, SingleConstructor "LinkedNumGetter" "LinkedNumGetter" "(./dhall/Types.dhall).LinkedNumGetter.Type"
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
, SingleConstructor "Tag" "Tag" "(./dhall/Types.dhall).Tag"
, SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt"
@ -98,6 +100,8 @@ deriveProduct
, "BudgetCurrency"
, "Exchange"
, "EntryNumGetter"
, "LinkedNumGetter"
, "LinkedEntryNumGetter"
, "TemporalScope"
, "SqlConfig"
, "PretaxValue"
@ -340,6 +344,10 @@ instance Ord DateMatcher where
deriving instance Hashable EntryNumGetter
deriving instance Hashable LinkedNumGetter
deriving instance Hashable LinkedEntryNumGetter
-------------------------------------------------------------------------------
-- top level type with fixed account tree to unroll the recursion in the dhall
-- account tree type
@ -421,9 +429,15 @@ data History
| HistStatement !Statement
deriving (Eq, Generic, Hashable, FromDhall)
type EntryGetter = Entry EntryAcnt EntryNumGetter TagID
type EntryGetter n = Entry EntryAcnt n TagID
instance FromDhall EntryGetter
type FromEntryGetter = EntryGetter EntryNumGetter
type ToEntryGetter = EntryGetter LinkedEntryNumGetter
instance FromDhall FromEntryGetter
instance FromDhall ToEntryGetter
deriving instance (Show a, Show v, Show t) => Show (Entry a v t)
@ -492,30 +506,30 @@ data FieldMatcher re
deriving instance Show (FieldMatcher T.Text)
data TxHalfGetter e = TxHalfGetter
{ thgAcnt :: !EntryAcnt
, thgComment :: !T.Text
, thgTags :: ![TagID]
, thgEntries :: ![e]
}
deriving (Eq, Generic, Hashable, Show)
deriving instance FromDhall (TxHalfGetter FromEntryGetter)
deriving instance FromDhall (TxHalfGetter ToEntryGetter)
data TxSubGetter = TxSubGetter
{ tsgFromAcnt :: !EntryAcnt
, tsgToAcnt :: !EntryAcnt
, tsgFromComment :: !T.Text
, tsgToComment :: !T.Text
, tsgFromTags :: ![TagID]
, tsgToTags :: ![TagID]
{ tsgFrom :: !(TxHalfGetter FromEntryGetter)
, tsgTo :: !(TxHalfGetter ToEntryGetter)
, tsgValue :: !EntryNumGetter
, tsgCurrency :: !EntryCur
, tsgFromEntries :: ![EntryGetter]
, tsgToEntries :: ![EntryGetter]
}
deriving (Eq, Generic, Hashable, Show, FromDhall)
data TxGetter = TxGetter
{ tgFromAcnt :: !EntryAcnt
, tgToAcnt :: !EntryAcnt
, tgFromComment :: !T.Text
, tgToComment :: !T.Text
, tgFromTags :: ![TagID]
, tgToTags :: ![TagID]
{ tgFrom :: !(TxHalfGetter FromEntryGetter)
, tgTo :: !(TxHalfGetter ToEntryGetter)
, tgCurrency :: !EntryCur
, tgFromEntries :: ![EntryGetter]
, tgToEntries :: ![EntryGetter]
, tgOtherEntries :: ![TxSubGetter]
}
deriving (Eq, Generic, Hashable, Show, FromDhall)

View File

@ -138,23 +138,26 @@ accountSign IncomeT = Credit
accountSign LiabilityT = Credit
accountSign EquityT = Credit
data HalfEntrySet a c t v = HalfEntrySet
{ hesPrimary :: !(Entry a () t)
, hesOther :: ![Entry a v t]
}
data EntrySet a c t v = EntrySet
{ desTotalValue :: !Rational
, desCurrency :: !c
, desFromEntry0 :: !(Entry a () t)
, desFromEntries :: ![Entry a v t]
, desToEntries :: ![Entry a v t]
, desToEntryBal :: !(Entry a () t)
{ esTotalValue :: !Rational
, esCurrency :: !c
, esFrom :: !(HalfEntrySet a c t (Deferred v))
, esTo :: !(HalfEntrySet a c t (LinkDeferred v))
}
data Tx e = Tx
{ dtxDescr :: !T.Text
, dtxDate :: !Day
, dtxEntries :: !e
{ txDescr :: !T.Text
, txDate :: !Day
, txEntries :: !e
}
deriving (Generic)
type DeferredEntrySet = EntrySet AcntID CurID TagID (Deferred Rational)
type DeferredEntrySet = EntrySet AcntID CurID TagID Rational
type BalEntrySet = EntrySet AcntID CurID TagID Rational
@ -169,6 +172,11 @@ type KeyTx = Tx [KeyEntry]
data Deferred a = Deferred Bool a
deriving (Show, Functor, Foldable, Traversable)
data LinkDeferred a
= LinkDeferred (Deferred a)
| LinkIndex LinkedNumGetter
deriving (Show, Functor, Foldable, Traversable)
-- type RawEntry = Entry AcntID (Deferred Rational) CurID TagID
-- type RawFromEntry = Entry AcntID (Deferred Rational) CurID TagID

View File

@ -310,105 +310,131 @@ matches
toTx :: TxGetter -> TxRecord -> InsertExceptT CurrencyM DeferredTx
toTx
TxGetter
{ tgFromAcnt
, tgToAcnt
, tgFromComment
, tgToComment
, tgFromTags
, tgToTags
{ tgFrom
, tgTo
, tgCurrency
, tgFromEntries
, tgToEntries
, tgOtherEntries
}
r@TxRecord {trAmount, trDate, trDesc} = do
combineError3 acntRes curRes subRes $ \(fa, ta) (cur, fe, te) ss ->
combineError curRes subRes $ \(cur, f, t) ss ->
Tx
{ dtxDate = trDate
, dtxDescr = trDesc
, dtxEntries =
{ txDate = trDate
, txDescr = trDesc
, txEntries =
EntrySet
{ desTotalValue = trAmount
, desCurrency = cur
, desFromEntry0 = entry0 fa tgFromComment tgFromTags
, desFromEntries = fe
, desToEntries = te
, desToEntryBal = entry0 ta tgToComment tgToTags
{ esTotalValue = trAmount
, esCurrency = cur
, esFrom = f
, esTo = t
}
: ss
}
where
resolveAcnt_ = liftInner . resolveAcnt r
acntRes =
combineError
(resolveAcnt_ tgFromAcnt)
(resolveAcnt_ tgToAcnt)
(,)
curRes = do
cur <- liftInner $ resolveCurrency r tgCurrency
let feRes = mapErrors (resolveEntry cur r) tgFromEntries
let teRes = mapErrors (resolveEntry cur r) tgToEntries
combineError feRes teRes (cur,,)
let fromRes = resolveHalfEntry resolveFromValue cur r tgFrom
let toRes = resolveHalfEntry resolveToValue cur r tgTo
combineError fromRes toRes (cur,,)
subRes = mapErrors (resolveSubGetter r) tgOtherEntries
entry0 a c ts = Entry {eAcnt = a, eValue = (), eComment = c, eTags = ts}
resolveSubGetter
:: TxRecord
-> TxSubGetter
-> InsertExceptT CurrencyM DeferredEntrySet
resolveSubGetter
r
TxSubGetter
{ tsgFromAcnt
, tsgToAcnt
, tsgFromTags
, tsgToTags
, tsgFromComment
, tsgToComment
, tsgValue
, tsgCurrency
, tsgFromEntries
, tsgToEntries
} = combineErrorM acntRes curRes $ \(fa, ta) (cur, fe, te) ->
do
-> InsertExceptT CurrencyM (EntrySet AcntID CurID TagID Rational)
resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
m <- ask
-- TODO laaaaame...
(Deferred _ val) <- liftInner $ mapM (roundPrecisionCur cur m) =<< resolveValue r tsgValue
let fromEntry =
Entry
{ eAcnt = fa
, eValue = ()
, eComment = tsgFromComment
, eTags = tsgFromTags
}
let toEntry =
Entry
{ eAcnt = ta
, eValue = ()
, eComment = tsgToComment
, eTags = tsgToTags
}
return
cur <- liftInner $ resolveCurrency r tsgCurrency
(_, val) <- liftInner $ mapM (roundPrecisionCur cur m) =<< resolveValue r tsgValue
let fromRes = resolveHalfEntry resolveFromValue cur r tsgFrom
let toRes = resolveHalfEntry resolveToValue cur r tsgTo
combineError fromRes toRes $ \f t ->
EntrySet
{ desTotalValue = val
, desCurrency = cur
, desFromEntry0 = fromEntry
, desFromEntries = fe
, desToEntries = te
, desToEntryBal = toEntry
{ esTotalValue = val
, esCurrency = cur
, esFrom = f
, esTo = t
}
resolveHalfEntry
:: Traversable f
=> (TxRecord -> n -> InsertExcept (f Double))
-> CurID
-> TxRecord
-> TxHalfGetter (EntryGetter n)
-> InsertExceptT CurrencyM (HalfEntrySet AcntID CurID TagID (f Rational))
resolveHalfEntry f cur r TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} =
combineError acntRes esRes $ \a es ->
HalfEntrySet
{ hesPrimary =
Entry
{ eAcnt = a
, eValue = ()
, eComment = thgComment
, eTags = thgTags
}
, hesOther = es
}
where
resolveAcnt_ = liftInner . resolveAcnt r
acntRes =
combineError
(resolveAcnt_ tsgFromAcnt)
(resolveAcnt_ tsgToAcnt)
(,)
curRes = do
cur <- liftInner $ resolveCurrency r tsgCurrency
let feRes = mapErrors (resolveEntry cur r) tsgFromEntries
let teRes = mapErrors (resolveEntry cur r) tsgToEntries
combineError feRes teRes (cur,,)
acntRes = liftInner $ resolveAcnt r thgAcnt
esRes = mapErrors (resolveEntry f cur r) thgEntries
-- resolveSubGetter
-- :: TxRecord
-- -> TxSubGetter
-- -> InsertExceptT CurrencyM DeferredEntrySet
-- resolveSubGetter
-- r
-- TxSubGetter
-- { tsgFromAcnt
-- , tsgToAcnt
-- , tsgFromTags
-- , tsgToTags
-- , tsgFromComment
-- , tsgToComment
-- , tsgValue
-- , tsgCurrency
-- , tsgFromEntries
-- , tsgToEntries
-- } = combineErrorM acntRes curRes $ \(fa, ta) (cur, fe, te) ->
-- do
-- m <- ask
-- -- TODO laaaaame...
-- (Deferred _ val) <- liftInner $ mapM (roundPrecisionCur cur m) =<< resolveValue r tsgValue
-- let fromEntry =
-- Entry
-- { eAcnt = fa
-- , eValue = ()
-- , eComment = tsgFromComment
-- , eTags = tsgFromTags
-- }
-- let toEntry =
-- Entry
-- { eAcnt = ta
-- , eValue = ()
-- , eComment = tsgToComment
-- , eTags = tsgToTags
-- }
-- return
-- EntrySet
-- { desTotalValue = val
-- , desCurrency = cur
-- , desFromEntry0 = fromEntry
-- , desFromEntries = fe
-- , desToEntries = te
-- , desToEntryBal = toEntry
-- }
-- where
-- resolveAcnt_ = liftInner . resolveAcnt r
-- acntRes =
-- combineError
-- (resolveAcnt_ tsgFromAcnt)
-- (resolveAcnt_ tsgToAcnt)
-- (,)
-- curRes = do
-- cur <- liftInner $ resolveCurrency r tsgCurrency
-- let feRes = mapErrors (resolveEntry cur r) tsgFromEntries
-- let teRes = mapErrors (resolveEntry cur r) tsgToEntries
-- combineError feRes teRes (cur,,)
valMatches :: ValMatcher -> Rational -> InsertExcept Bool
valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
@ -434,20 +460,35 @@ otherMatches dict m = case m of
where
lookup_ t n = lookupErr (MatchField t) n dict
-- TODO this should be more general?
resolveEntry
:: CurID
:: Traversable f
=> (TxRecord -> n -> InsertExcept (f Double))
-> CurID
-> TxRecord
-> EntryGetter
-> InsertExceptT CurrencyM (Entry AcntID (Deferred Rational) TagID)
resolveEntry cur r s@Entry {eAcnt, eValue} = do
-> EntryGetter n
-> InsertExceptT CurrencyM (Entry AcntID (f Rational) TagID)
resolveEntry f cur r s@Entry {eAcnt, eValue} = do
m <- ask
liftInner $ combineErrorM acntRes valRes $ \a v -> do
v' <- mapM (roundPrecisionCur cur m) v
return $ s {eAcnt = a, eValue = v'}
where
acntRes = resolveAcnt r eAcnt
valRes = resolveValue r eValue
valRes = f r eValue
-- resolveEntry
-- :: CurID
-- -> TxRecord
-- -> EntryGetter n
-- -> InsertExceptT CurrencyM (Entry AcntID (Deferred Rational) TagID)
-- resolveEntry cur r s@Entry {eAcnt, eValue} = do
-- m <- ask
-- liftInner $ combineErrorM acntRes valRes $ \a v -> do
-- v' <- mapM (roundPrecisionCur cur m) v
-- return $ s {eAcnt = a, eValue = v'}
-- where
-- acntRes = resolveAcnt r eAcnt
-- valRes = resolveValue r eValue
-- curRes = resolveCurrency r eCurrency
@ -556,19 +597,21 @@ mapErrorsIO f xs = mapM go $ enumTraversable xs
collectErrorsIO :: (Traversable t, MonadUnliftIO m) => t (m a) -> m (t a)
collectErrorsIO = mapErrorsIO id
resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept (Deferred Double)
resolveValue TxRecord {trOther, trAmount} s = case s of
(LookupN t) -> Deferred False <$> (readDouble =<< lookupErr EntryValField t trOther)
(ConstN c) -> return $ Deferred False c
AmountN m -> return $ Deferred False $ (* m) $ fromRational trAmount
BalanceN x -> return $ Deferred True x
resolveFromValue :: TxRecord -> EntryNumGetter -> InsertExcept (Deferred Double)
resolveFromValue r = fmap (uncurry Deferred) . resolveValue r
-- -- TODO not DRY
-- resolveToValue :: TxRecord -> ToEntryNumGetter -> InsertExcept Double
-- resolveToValue TxRecord {trOther, trAmount} s = case s of
-- (TLookupN t) -> readDouble =<< lookupErr EntryValField t trOther
-- (TConstN c) -> return c
-- TAmountN m -> return $ (* m) $ fromRational trAmount
resolveToValue :: TxRecord -> LinkedEntryNumGetter -> InsertExcept (LinkDeferred Double)
resolveToValue _ (Linked l) = return $ LinkIndex l
resolveToValue r (Getter g) = do
(l, v) <- resolveValue r g
return $ LinkDeferred (Deferred l v)
resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept (Bool, Double)
resolveValue TxRecord {trOther, trAmount} s = case s of
(LookupN t) -> (False,) <$> (readDouble =<< lookupErr EntryValField t trOther)
(ConstN c) -> return (False, c)
AmountN m -> return $ (False,) <$> (* m) $ fromRational trAmount
BalanceN x -> return (True, x)
resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text
resolveAcnt = resolveEntryField AcntField