ADD linked credit entries
This commit is contained in:
parent
c2525fb77c
commit
03e75ce549
|
|
@ -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
|
||||
, default = { eComment = "", eTags = [] : List 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
|
||||
, tsgFrom : (TxHalfGetter FromEntryGetter.Type).Type
|
||||
, tsgTo : (TxHalfGetter ToEntryGetter.Type).Type
|
||||
}
|
||||
, default =
|
||||
{ tsgFromTags = [] : List TagID
|
||||
, tsgToTags = [] : List TagID
|
||||
, tsgFromComment = ""
|
||||
, tsgToComment = ""
|
||||
, tsgFromEntries = [] : List EntryGetter.Type
|
||||
, tsgToEntries = [] : List EntryGetter.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
|
||||
|
|
|
|||
|
|
@ -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) ->
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
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,,)
|
||||
-> InsertExceptT CurrencyM (EntrySet AcntID CurID TagID Rational)
|
||||
resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
|
||||
m <- ask
|
||||
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
|
||||
{ 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
|
||||
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
|
||||
|
|
|
|||
Loading…
Reference in New Issue