Compare commits
No commits in common. "f3d2c1655e0e757110bef79d49ab8cd390ba4989" and "c2525fb77cfb48e72d4e326c8054042426200b02" have entirely different histories.
f3d2c1655e
...
c2525fb77c
|
@ -411,35 +411,6 @@ let EntryNumGetter =
|
||||||
| BalanceN : Double
|
| 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 =
|
let EntryTextGetter =
|
||||||
{-
|
{-
|
||||||
Means to get a textual value from a statement row.
|
Means to get a textual value from a statement row.
|
||||||
|
@ -502,100 +473,115 @@ let Entry =
|
||||||
|
|
||||||
let EntryGetter =
|
let EntryGetter =
|
||||||
{-
|
{-
|
||||||
Means for getting an entry from a given row in a statement (debit side)
|
Means for getting an entry from a given row in a statement
|
||||||
-}
|
-}
|
||||||
\(n : Type) ->
|
{ Type = Entry EntryAcntGetter EntryNumGetter TagID
|
||||||
{ Type = Entry EntryAcntGetter n TagID
|
, default = { eComment = "", eTags = [] : List 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 =
|
let TxSubGetter =
|
||||||
{-
|
{-
|
||||||
A means for transforming one row in a statement to a transaction
|
A means for transforming one row in a statement to a transaction
|
||||||
-}
|
-}
|
||||||
{ Type =
|
{ Type =
|
||||||
{ tsgValue : EntryNumGetter
|
{ tsgFromAcnt : EntryAcntGetter
|
||||||
|
, tsgToAcnt : EntryAcntGetter
|
||||||
|
, tsgValue : EntryNumGetter
|
||||||
, tsgCurrency : EntryCurGetter
|
, tsgCurrency : EntryCurGetter
|
||||||
, tsgFrom : (TxHalfGetter FromEntryGetter.Type).Type
|
, tsgFromEntries : List EntryGetter.Type
|
||||||
, tsgTo : (TxHalfGetter ToEntryGetter.Type).Type
|
, tsgFromComment : Text
|
||||||
|
, tsgToComment : Text
|
||||||
|
, tsgFromTags : List TagID
|
||||||
|
, tsgToTags : List TagID
|
||||||
|
, tsgToEntries : List EntryGetter.Type
|
||||||
}
|
}
|
||||||
, default = { tsgFrom = TxHalfGetter, tsgTo = TxHalfGetter }
|
, default =
|
||||||
|
{ tsgFromTags = [] : List TagID
|
||||||
|
, tsgToTags = [] : List TagID
|
||||||
|
, tsgFromComment = ""
|
||||||
|
, tsgToComment = ""
|
||||||
|
, tsgFromEntries = [] : List EntryGetter.Type
|
||||||
|
, tsgToEntries = [] : List EntryGetter.Type
|
||||||
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
let TxGetter =
|
let TxGetter =
|
||||||
{-
|
{-
|
||||||
A means for transforming one row in a statement to a transaction
|
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 =
|
{ Type =
|
||||||
{ tgFrom : (TxHalfGetter FromEntryGetter.Type).Type
|
{ tgFromAcnt :
|
||||||
, tgTo : (TxHalfGetter ToEntryGetter.Type).Type
|
{-
|
||||||
, tgCurrency : EntryCurGetter
|
Account from which this transaction will be balanced. The value of
|
||||||
, tgOtherEntries : List TxSubGetter.Type
|
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
|
||||||
}
|
}
|
||||||
, default =
|
, default =
|
||||||
{ tgOtherEntries = [] : List TxSubGetter.Type
|
{ tgOtherEntries = [] : List TxSubGetter.Type
|
||||||
, tsgFrom = TxHalfGetter
|
, tgFromTags = [] : List TagID
|
||||||
, tsgTo = TxHalfGetter
|
, tgToTags = [] : List TagID
|
||||||
|
, tgFromEntries = [] : List EntryGetter.Type
|
||||||
|
, tgToEntries = [] : List EntryGetter.Type
|
||||||
|
, tgFromComment = ""
|
||||||
|
, tgToComment = ""
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -1142,13 +1128,10 @@ in { CurID
|
||||||
, FieldMatcher
|
, FieldMatcher
|
||||||
, FieldMatcher_
|
, FieldMatcher_
|
||||||
, EntryNumGetter
|
, EntryNumGetter
|
||||||
, LinkedEntryNumGetter
|
|
||||||
, LinkedNumGetter
|
|
||||||
, Field
|
, Field
|
||||||
, FieldMap
|
, FieldMap
|
||||||
, Entry
|
, Entry
|
||||||
, FromEntryGetter
|
, EntryGetter
|
||||||
, ToEntryGetter
|
|
||||||
, EntryTextGetter
|
, EntryTextGetter
|
||||||
, EntryCurGetter
|
, EntryCurGetter
|
||||||
, EntryAcntGetter
|
, EntryAcntGetter
|
||||||
|
|
|
@ -7,7 +7,7 @@ let T = ./Types.dhall
|
||||||
let nullEntry =
|
let nullEntry =
|
||||||
\(a : T.EntryAcntGetter) ->
|
\(a : T.EntryAcntGetter) ->
|
||||||
\(v : T.EntryNumGetter) ->
|
\(v : T.EntryNumGetter) ->
|
||||||
T.FromEntryGetter::{ eAcnt = a, eValue = v }
|
T.EntryGetter::{ eAcnt = a, eValue = v }
|
||||||
|
|
||||||
let nullOpts = T.TxOpts::{=}
|
let nullOpts = T.TxOpts::{=}
|
||||||
|
|
||||||
|
@ -99,7 +99,7 @@ let partN =
|
||||||
(T.EntryNumGetter.ConstN x._2)
|
(T.EntryNumGetter.ConstN x._2)
|
||||||
// { eComment = x._3 }
|
// { eComment = x._3 }
|
||||||
|
|
||||||
in List/map PartEntry T.FromEntryGetter.Type toEntry ss
|
in List/map PartEntry T.EntryGetter.Type toEntry ss
|
||||||
|
|
||||||
let addDay =
|
let addDay =
|
||||||
\(x : T.GregorianM) ->
|
\(x : T.GregorianM) ->
|
||||||
|
|
|
@ -69,7 +69,7 @@ readHistStmt
|
||||||
readHistStmt root i = whenHash_ CTImport i $ do
|
readHistStmt root i = whenHash_ CTImport i $ do
|
||||||
bs <- readImport root i
|
bs <- readImport root i
|
||||||
bounds <- askDBState kmStatementInterval
|
bounds <- askDBState kmStatementInterval
|
||||||
return $ filter (inDaySpan bounds . txDate) bs
|
return $ filter (inDaySpan bounds . dtxDate) bs
|
||||||
|
|
||||||
splitHistory :: [History] -> ([HistTransfer], [Statement])
|
splitHistory :: [History] -> ([HistTransfer], [Statement])
|
||||||
splitHistory = partitionEithers . fmap go
|
splitHistory = partitionEithers . fmap go
|
||||||
|
@ -101,14 +101,16 @@ txPair
|
||||||
-> DeferredTx
|
-> DeferredTx
|
||||||
txPair day from to cur val desc =
|
txPair day from to cur val desc =
|
||||||
Tx
|
Tx
|
||||||
{ txDescr = desc
|
{ dtxDescr = desc
|
||||||
, txDate = day
|
, dtxDate = day
|
||||||
, txEntries =
|
, dtxEntries =
|
||||||
[ EntrySet
|
[ EntrySet
|
||||||
{ esTotalValue = -val
|
{ desTotalValue = -val
|
||||||
, esCurrency = cur
|
, desCurrency = cur
|
||||||
, esFrom = HalfEntrySet {hesPrimary = entry from, hesOther = []}
|
, desFromEntry0 = entry from
|
||||||
, esTo = HalfEntrySet {hesPrimary = entry to, hesOther = []}
|
, desToEntryBal = entry to
|
||||||
|
, desFromEntries = []
|
||||||
|
, desToEntries = []
|
||||||
}
|
}
|
||||||
]
|
]
|
||||||
}
|
}
|
||||||
|
@ -122,11 +124,11 @@ txPair day from to cur val desc =
|
||||||
}
|
}
|
||||||
|
|
||||||
resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx
|
resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx
|
||||||
resolveTx t@Tx {txEntries = ss} =
|
resolveTx t@Tx {dtxEntries = ss} =
|
||||||
(\kss -> t {txEntries = kss}) <$> mapErrors resolveEntry ss
|
(\kss -> t {dtxEntries = kss}) <$> mapErrors resolveEntry ss
|
||||||
|
|
||||||
insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m ()
|
insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m ()
|
||||||
insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do
|
insertTx c Tx {dtxDate = d, dtxDescr = e, dtxEntries = ss} = do
|
||||||
k <- insert $ TransactionR c d e
|
k <- insert $ TransactionR c d e
|
||||||
mapM_ (insertEntry k) ss
|
mapM_ (insertEntry k) ss
|
||||||
|
|
||||||
|
@ -335,78 +337,56 @@ balanceTxs
|
||||||
=> [(CommitR, DeferredTx)]
|
=> [(CommitR, DeferredTx)]
|
||||||
-> m [(CommitR, KeyTx)]
|
-> m [(CommitR, KeyTx)]
|
||||||
balanceTxs ts = do
|
balanceTxs ts = do
|
||||||
keyts <- mapErrors resolveTx =<< evalStateT (mapM go ts') M.empty
|
keyts <- mapErrors resolveTx $ snd $ L.mapAccumL go M.empty ts'
|
||||||
return $ zip cs keyts
|
return $ zip cs keyts
|
||||||
where
|
where
|
||||||
(cs, ts') = L.unzip $ L.sortOn (txDate . snd) ts
|
(cs, ts') = L.unzip $ L.sortOn (dtxDate . snd) ts
|
||||||
go t@Tx {txEntries, txDate} =
|
go bals t@Tx {dtxEntries} =
|
||||||
(\es -> t {txEntries = concat es}) <$> mapM (balanceEntrySet txDate) txEntries
|
second (\es -> t {dtxEntries = concat es}) $
|
||||||
|
L.mapAccumL balanceEntrySet bals dtxEntries
|
||||||
|
|
||||||
type EntryBals = M.Map (AcntID, CurID) Rational
|
type EntryBals = M.Map (AcntID, CurID) Rational
|
||||||
|
|
||||||
-- TODO might be faster to also do all the key stuff here since currency
|
-- 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
|
-- will be looked up for every entry rather then the entire entry set
|
||||||
|
balanceEntrySet :: EntryBals -> DeferredEntrySet -> (EntryBals, [BalEntry])
|
||||||
balanceEntrySet
|
balanceEntrySet
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
bals
|
||||||
=> Day
|
|
||||||
-> DeferredEntrySet
|
|
||||||
-> StateT EntryBals m [BalEntry]
|
|
||||||
balanceEntrySet
|
|
||||||
day
|
|
||||||
EntrySet
|
EntrySet
|
||||||
{ esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
|
{ desFromEntry0
|
||||||
, esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
|
, desFromEntries
|
||||||
, esCurrency
|
, desToEntryBal
|
||||||
, esTotalValue
|
, desToEntries
|
||||||
} =
|
, desCurrency
|
||||||
do
|
, desTotalValue
|
||||||
let (lts, dts) = partitionEithers $ splitLinked <$> ts
|
} = flipTup $ runState doBalAll bals
|
||||||
fs' <- doEntries fs esTotalValue f0
|
|
||||||
let fv = V.fromList $ fmap eValue fs'
|
|
||||||
lts' <- lift $ mapErrors (resolveLinked fv esCurrency day) lts
|
|
||||||
ts' <- doEntries (dts ++ lts') (-esTotalValue) t0
|
|
||||||
return $ toFull <$> fs' ++ ts'
|
|
||||||
where
|
where
|
||||||
|
flipTup (a, b) = (b, a)
|
||||||
doEntries es tot e0 = do
|
doEntries es tot e0 = do
|
||||||
es' <- liftInnerS $ mapM (balanceEntry esCurrency) es
|
es' <- state (\b -> flipTup $ L.mapAccumL (balanceEntry desCurrency) b es)
|
||||||
let val0 = tot - entrySum es'
|
let val0 = tot - entrySum es'
|
||||||
modify $ mapAdd_ (eAcnt e0, esCurrency) val0
|
modify $ mapAdd_ (eAcnt e0, desCurrency) val0
|
||||||
return $ e0 {eValue = val0} : es'
|
return $ e0 {eValue = val0} : es'
|
||||||
toFull e = FullEntry {feEntry = e, feCurrency = esCurrency}
|
doBalAll = do
|
||||||
splitLinked e@Entry {eValue} = case eValue of
|
fes <- doEntries desFromEntries desTotalValue desFromEntry0
|
||||||
LinkIndex l -> Left e {eValue = l}
|
tes <- doEntries desToEntries (-desTotalValue) desToEntryBal
|
||||||
LinkDeferred d -> Right e {eValue = d}
|
return $ toFull <$> fes ++ tes
|
||||||
liftInnerS = mapStateT (return . runIdentity)
|
toFull e = FullEntry {feEntry = e, feCurrency = desCurrency}
|
||||||
|
|
||||||
resolveLinked
|
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
|
||||||
=> Vector Rational
|
|
||||||
-> CurID
|
|
||||||
-> Day
|
|
||||||
-> Entry AcntID LinkedNumGetter TagID
|
|
||||||
-> m (Entry AcntID (Deferred Rational) TagID)
|
|
||||||
resolveLinked from cur day e@Entry {eValue = LinkedNumGetter {lngIndex, lngScale}} = do
|
|
||||||
curMap <- askDBState kmCurrency
|
|
||||||
case from V.!? fromIntegral lngIndex of
|
|
||||||
Nothing -> throwError $ InsertException [IndexError e day]
|
|
||||||
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 :: Num v => [Entry a v t] -> v
|
||||||
entrySum = sum . fmap eValue
|
entrySum = sum . fmap eValue
|
||||||
|
|
||||||
balanceEntry
|
balanceEntry
|
||||||
:: CurID
|
:: CurID
|
||||||
|
-> EntryBals
|
||||||
-> Entry AcntID (Deferred Rational) TagID
|
-> Entry AcntID (Deferred Rational) TagID
|
||||||
-> State EntryBals (Entry AcntID Rational TagID)
|
-> (EntryBals, Entry AcntID Rational TagID)
|
||||||
balanceEntry curID e@Entry {eValue = Deferred toBal v, eAcnt} = do
|
balanceEntry curID bals e@Entry {eValue = Deferred toBal v, eAcnt} =
|
||||||
curBal <- gets (M.findWithDefault 0 key)
|
(mapAdd_ key newVal bals, e {eValue = newVal})
|
||||||
let newVal = if toBal then v - curBal else v
|
|
||||||
modify (mapAdd_ key newVal)
|
|
||||||
return $ e {eValue = newVal}
|
|
||||||
where
|
where
|
||||||
key = (eAcnt, curID)
|
key = (eAcnt, curID)
|
||||||
|
curBal = M.findWithDefault 0 key bals
|
||||||
|
newVal = if toBal then v - curBal else v
|
||||||
|
|
||||||
-- -- reimplementation from future version :/
|
-- -- reimplementation from future version :/
|
||||||
-- mapAccumM
|
-- mapAccumM
|
||||||
|
|
|
@ -33,12 +33,10 @@ makeHaskellTypesWith
|
||||||
, MultipleConstructors "YMDMatcher" "(./dhall/Types.dhall).YMDMatcher"
|
, MultipleConstructors "YMDMatcher" "(./dhall/Types.dhall).YMDMatcher"
|
||||||
, 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 "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
|
, MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
|
||||||
, MultipleConstructors "BudgetTransferType" "(./dhall/Types.dhall).BudgetTransferType"
|
, MultipleConstructors "BudgetTransferType" "(./dhall/Types.dhall).BudgetTransferType"
|
||||||
, MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod"
|
, MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod"
|
||||||
, MultipleConstructors "PeriodType" "(./dhall/Types.dhall).PeriodType"
|
, MultipleConstructors "PeriodType" "(./dhall/Types.dhall).PeriodType"
|
||||||
, SingleConstructor "LinkedNumGetter" "LinkedNumGetter" "(./dhall/Types.dhall).LinkedNumGetter.Type"
|
|
||||||
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
|
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
|
||||||
, SingleConstructor "Tag" "Tag" "(./dhall/Types.dhall).Tag"
|
, SingleConstructor "Tag" "Tag" "(./dhall/Types.dhall).Tag"
|
||||||
, SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt"
|
, SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt"
|
||||||
|
@ -100,8 +98,6 @@ deriveProduct
|
||||||
, "BudgetCurrency"
|
, "BudgetCurrency"
|
||||||
, "Exchange"
|
, "Exchange"
|
||||||
, "EntryNumGetter"
|
, "EntryNumGetter"
|
||||||
, "LinkedNumGetter"
|
|
||||||
, "LinkedEntryNumGetter"
|
|
||||||
, "TemporalScope"
|
, "TemporalScope"
|
||||||
, "SqlConfig"
|
, "SqlConfig"
|
||||||
, "PretaxValue"
|
, "PretaxValue"
|
||||||
|
@ -344,10 +340,6 @@ instance Ord DateMatcher where
|
||||||
|
|
||||||
deriving instance Hashable EntryNumGetter
|
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
|
-- top level type with fixed account tree to unroll the recursion in the dhall
|
||||||
-- account tree type
|
-- account tree type
|
||||||
|
@ -429,15 +421,9 @@ data History
|
||||||
| HistStatement !Statement
|
| HistStatement !Statement
|
||||||
deriving (Eq, Generic, Hashable, FromDhall)
|
deriving (Eq, Generic, Hashable, FromDhall)
|
||||||
|
|
||||||
type EntryGetter n = Entry EntryAcnt n TagID
|
type EntryGetter = Entry EntryAcnt EntryNumGetter TagID
|
||||||
|
|
||||||
type FromEntryGetter = EntryGetter EntryNumGetter
|
instance FromDhall EntryGetter
|
||||||
|
|
||||||
type ToEntryGetter = EntryGetter LinkedEntryNumGetter
|
|
||||||
|
|
||||||
instance FromDhall FromEntryGetter
|
|
||||||
|
|
||||||
instance FromDhall ToEntryGetter
|
|
||||||
|
|
||||||
deriving instance (Show a, Show v, Show t) => Show (Entry a v t)
|
deriving instance (Show a, Show v, Show t) => Show (Entry a v t)
|
||||||
|
|
||||||
|
@ -506,30 +492,30 @@ data FieldMatcher re
|
||||||
|
|
||||||
deriving instance Show (FieldMatcher T.Text)
|
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
|
data TxSubGetter = TxSubGetter
|
||||||
{ tsgFrom :: !(TxHalfGetter FromEntryGetter)
|
{ tsgFromAcnt :: !EntryAcnt
|
||||||
, tsgTo :: !(TxHalfGetter ToEntryGetter)
|
, tsgToAcnt :: !EntryAcnt
|
||||||
|
, tsgFromComment :: !T.Text
|
||||||
|
, tsgToComment :: !T.Text
|
||||||
|
, tsgFromTags :: ![TagID]
|
||||||
|
, tsgToTags :: ![TagID]
|
||||||
, tsgValue :: !EntryNumGetter
|
, tsgValue :: !EntryNumGetter
|
||||||
, tsgCurrency :: !EntryCur
|
, tsgCurrency :: !EntryCur
|
||||||
|
, tsgFromEntries :: ![EntryGetter]
|
||||||
|
, tsgToEntries :: ![EntryGetter]
|
||||||
}
|
}
|
||||||
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
||||||
|
|
||||||
data TxGetter = TxGetter
|
data TxGetter = TxGetter
|
||||||
{ tgFrom :: !(TxHalfGetter FromEntryGetter)
|
{ tgFromAcnt :: !EntryAcnt
|
||||||
, tgTo :: !(TxHalfGetter ToEntryGetter)
|
, tgToAcnt :: !EntryAcnt
|
||||||
|
, tgFromComment :: !T.Text
|
||||||
|
, tgToComment :: !T.Text
|
||||||
|
, tgFromTags :: ![TagID]
|
||||||
|
, tgToTags :: ![TagID]
|
||||||
, tgCurrency :: !EntryCur
|
, tgCurrency :: !EntryCur
|
||||||
|
, tgFromEntries :: ![EntryGetter]
|
||||||
|
, tgToEntries :: ![EntryGetter]
|
||||||
, tgOtherEntries :: ![TxSubGetter]
|
, tgOtherEntries :: ![TxSubGetter]
|
||||||
}
|
}
|
||||||
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
||||||
|
|
|
@ -138,26 +138,23 @@ accountSign IncomeT = Credit
|
||||||
accountSign LiabilityT = Credit
|
accountSign LiabilityT = Credit
|
||||||
accountSign EquityT = 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
|
data EntrySet a c t v = EntrySet
|
||||||
{ esTotalValue :: !Rational
|
{ desTotalValue :: !Rational
|
||||||
, esCurrency :: !c
|
, desCurrency :: !c
|
||||||
, esFrom :: !(HalfEntrySet a c t (Deferred v))
|
, desFromEntry0 :: !(Entry a () t)
|
||||||
, esTo :: !(HalfEntrySet a c t (LinkDeferred v))
|
, desFromEntries :: ![Entry a v t]
|
||||||
|
, desToEntries :: ![Entry a v t]
|
||||||
|
, desToEntryBal :: !(Entry a () t)
|
||||||
}
|
}
|
||||||
|
|
||||||
data Tx e = Tx
|
data Tx e = Tx
|
||||||
{ txDescr :: !T.Text
|
{ dtxDescr :: !T.Text
|
||||||
, txDate :: !Day
|
, dtxDate :: !Day
|
||||||
, txEntries :: !e
|
, dtxEntries :: !e
|
||||||
}
|
}
|
||||||
deriving (Generic)
|
deriving (Generic)
|
||||||
|
|
||||||
type DeferredEntrySet = EntrySet AcntID CurID TagID Rational
|
type DeferredEntrySet = EntrySet AcntID CurID TagID (Deferred Rational)
|
||||||
|
|
||||||
type BalEntrySet = EntrySet AcntID CurID TagID Rational
|
type BalEntrySet = EntrySet AcntID CurID TagID Rational
|
||||||
|
|
||||||
|
@ -172,11 +169,6 @@ type KeyTx = Tx [KeyEntry]
|
||||||
data Deferred a = Deferred Bool a
|
data Deferred a = Deferred Bool a
|
||||||
deriving (Show, Functor, Foldable, Traversable)
|
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 RawEntry = Entry AcntID (Deferred Rational) CurID TagID
|
||||||
|
|
||||||
-- type RawFromEntry = Entry AcntID (Deferred Rational) CurID TagID
|
-- type RawFromEntry = Entry AcntID (Deferred Rational) CurID TagID
|
||||||
|
@ -221,10 +213,9 @@ data InsertError
|
||||||
| InsertIOError !T.Text
|
| InsertIOError !T.Text
|
||||||
| ParseError !T.Text
|
| ParseError !T.Text
|
||||||
| ConversionError !T.Text
|
| ConversionError !T.Text
|
||||||
| IndexError !(Entry AcntID LinkedNumGetter TagID) !Day
|
|
||||||
| RoundError !CurID
|
|
||||||
| LookupError !LookupSuberr !T.Text
|
| LookupError !LookupSuberr !T.Text
|
||||||
| IncomeError !Day !T.Text !Rational
|
| -- | BalanceError !BalanceType !CurID ![Entry AcntID (Maybe Rational) CurID TagID]
|
||||||
|
IncomeError !Day !T.Text !Rational
|
||||||
| PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
|
| PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
|
||||||
| DaySpanError !Gregorian !(Maybe Gregorian)
|
| DaySpanError !Gregorian !(Maybe Gregorian)
|
||||||
| StatementError ![TxRecord] ![MatchRe]
|
| StatementError ![TxRecord] ![MatchRe]
|
||||||
|
|
|
@ -310,131 +310,105 @@ matches
|
||||||
toTx :: TxGetter -> TxRecord -> InsertExceptT CurrencyM DeferredTx
|
toTx :: TxGetter -> TxRecord -> InsertExceptT CurrencyM DeferredTx
|
||||||
toTx
|
toTx
|
||||||
TxGetter
|
TxGetter
|
||||||
{ tgFrom
|
{ tgFromAcnt
|
||||||
, tgTo
|
, tgToAcnt
|
||||||
|
, tgFromComment
|
||||||
|
, tgToComment
|
||||||
|
, tgFromTags
|
||||||
|
, tgToTags
|
||||||
, tgCurrency
|
, tgCurrency
|
||||||
|
, tgFromEntries
|
||||||
|
, tgToEntries
|
||||||
, tgOtherEntries
|
, tgOtherEntries
|
||||||
}
|
}
|
||||||
r@TxRecord {trAmount, trDate, trDesc} = do
|
r@TxRecord {trAmount, trDate, trDesc} = do
|
||||||
combineError curRes subRes $ \(cur, f, t) ss ->
|
combineError3 acntRes curRes subRes $ \(fa, ta) (cur, fe, te) ss ->
|
||||||
Tx
|
Tx
|
||||||
{ txDate = trDate
|
{ dtxDate = trDate
|
||||||
, txDescr = trDesc
|
, dtxDescr = trDesc
|
||||||
, txEntries =
|
, dtxEntries =
|
||||||
EntrySet
|
EntrySet
|
||||||
{ esTotalValue = trAmount
|
{ desTotalValue = trAmount
|
||||||
, esCurrency = cur
|
, desCurrency = cur
|
||||||
, esFrom = f
|
, desFromEntry0 = entry0 fa tgFromComment tgFromTags
|
||||||
, esTo = t
|
, desFromEntries = fe
|
||||||
|
, desToEntries = te
|
||||||
|
, desToEntryBal = entry0 ta tgToComment tgToTags
|
||||||
}
|
}
|
||||||
: ss
|
: ss
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
|
resolveAcnt_ = liftInner . resolveAcnt r
|
||||||
|
acntRes =
|
||||||
|
combineError
|
||||||
|
(resolveAcnt_ tgFromAcnt)
|
||||||
|
(resolveAcnt_ tgToAcnt)
|
||||||
|
(,)
|
||||||
curRes = do
|
curRes = do
|
||||||
cur <- liftInner $ resolveCurrency r tgCurrency
|
cur <- liftInner $ resolveCurrency r tgCurrency
|
||||||
let fromRes = resolveHalfEntry resolveFromValue cur r tgFrom
|
let feRes = mapErrors (resolveEntry cur r) tgFromEntries
|
||||||
let toRes = resolveHalfEntry resolveToValue cur r tgTo
|
let teRes = mapErrors (resolveEntry cur r) tgToEntries
|
||||||
combineError fromRes toRes (cur,,)
|
combineError feRes teRes (cur,,)
|
||||||
subRes = mapErrors (resolveSubGetter r) tgOtherEntries
|
subRes = mapErrors (resolveSubGetter r) tgOtherEntries
|
||||||
|
entry0 a c ts = Entry {eAcnt = a, eValue = (), eComment = c, eTags = ts}
|
||||||
|
|
||||||
resolveSubGetter
|
resolveSubGetter
|
||||||
:: TxRecord
|
:: TxRecord
|
||||||
-> TxSubGetter
|
-> TxSubGetter
|
||||||
-> InsertExceptT CurrencyM (EntrySet AcntID CurID TagID Rational)
|
-> InsertExceptT CurrencyM DeferredEntrySet
|
||||||
resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
|
resolveSubGetter
|
||||||
m <- ask
|
r
|
||||||
cur <- liftInner $ resolveCurrency r tsgCurrency
|
TxSubGetter
|
||||||
(_, val) <- liftInner $ mapM (roundPrecisionCur cur m) =<< resolveValue r tsgValue
|
{ tsgFromAcnt
|
||||||
let fromRes = resolveHalfEntry resolveFromValue cur r tsgFrom
|
, tsgToAcnt
|
||||||
let toRes = resolveHalfEntry resolveToValue cur r tsgTo
|
, tsgFromTags
|
||||||
combineError fromRes toRes $ \f t ->
|
, tsgToTags
|
||||||
EntrySet
|
, tsgFromComment
|
||||||
{ esTotalValue = val
|
, tsgToComment
|
||||||
, esCurrency = cur
|
, tsgValue
|
||||||
, esFrom = f
|
, tsgCurrency
|
||||||
, esTo = t
|
, tsgFromEntries
|
||||||
}
|
, tsgToEntries
|
||||||
|
} = combineErrorM acntRes curRes $ \(fa, ta) (cur, fe, te) ->
|
||||||
resolveHalfEntry
|
do
|
||||||
:: Traversable f
|
m <- ask
|
||||||
=> (TxRecord -> n -> InsertExcept (f Double))
|
-- TODO laaaaame...
|
||||||
-> CurID
|
(Deferred _ val) <- liftInner $ mapM (roundPrecisionCur cur m) =<< resolveValue r tsgValue
|
||||||
-> TxRecord
|
let fromEntry =
|
||||||
-> TxHalfGetter (EntryGetter n)
|
Entry
|
||||||
-> InsertExceptT CurrencyM (HalfEntrySet AcntID CurID TagID (f Rational))
|
{ eAcnt = fa
|
||||||
resolveHalfEntry f cur r TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} =
|
, eValue = ()
|
||||||
combineError acntRes esRes $ \a es ->
|
, eComment = tsgFromComment
|
||||||
HalfEntrySet
|
, eTags = tsgFromTags
|
||||||
{ hesPrimary =
|
}
|
||||||
Entry
|
let toEntry =
|
||||||
{ eAcnt = a
|
Entry
|
||||||
, eValue = ()
|
{ eAcnt = ta
|
||||||
, eComment = thgComment
|
, eValue = ()
|
||||||
, eTags = thgTags
|
, eComment = tsgToComment
|
||||||
}
|
, eTags = tsgToTags
|
||||||
, hesOther = es
|
}
|
||||||
}
|
return
|
||||||
where
|
EntrySet
|
||||||
acntRes = liftInner $ resolveAcnt r thgAcnt
|
{ desTotalValue = val
|
||||||
esRes = mapErrors (resolveEntry f cur r) thgEntries
|
, desCurrency = cur
|
||||||
|
, desFromEntry0 = fromEntry
|
||||||
-- resolveSubGetter
|
, desFromEntries = fe
|
||||||
-- :: TxRecord
|
, desToEntries = te
|
||||||
-- -> TxSubGetter
|
, desToEntryBal = toEntry
|
||||||
-- -> InsertExceptT CurrencyM DeferredEntrySet
|
}
|
||||||
-- resolveSubGetter
|
where
|
||||||
-- r
|
resolveAcnt_ = liftInner . resolveAcnt r
|
||||||
-- TxSubGetter
|
acntRes =
|
||||||
-- { tsgFromAcnt
|
combineError
|
||||||
-- , tsgToAcnt
|
(resolveAcnt_ tsgFromAcnt)
|
||||||
-- , tsgFromTags
|
(resolveAcnt_ tsgToAcnt)
|
||||||
-- , tsgToTags
|
(,)
|
||||||
-- , tsgFromComment
|
curRes = do
|
||||||
-- , tsgToComment
|
cur <- liftInner $ resolveCurrency r tsgCurrency
|
||||||
-- , tsgValue
|
let feRes = mapErrors (resolveEntry cur r) tsgFromEntries
|
||||||
-- , tsgCurrency
|
let teRes = mapErrors (resolveEntry cur r) tsgToEntries
|
||||||
-- , tsgFromEntries
|
combineError feRes teRes (cur,,)
|
||||||
-- , 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 -> Rational -> InsertExcept Bool
|
||||||
valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
|
valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
|
||||||
|
@ -460,35 +434,20 @@ otherMatches dict m = case m of
|
||||||
where
|
where
|
||||||
lookup_ t n = lookupErr (MatchField t) n dict
|
lookup_ t n = lookupErr (MatchField t) n dict
|
||||||
|
|
||||||
|
-- TODO this should be more general?
|
||||||
resolveEntry
|
resolveEntry
|
||||||
:: Traversable f
|
:: CurID
|
||||||
=> (TxRecord -> n -> InsertExcept (f Double))
|
|
||||||
-> CurID
|
|
||||||
-> TxRecord
|
-> TxRecord
|
||||||
-> EntryGetter n
|
-> EntryGetter
|
||||||
-> InsertExceptT CurrencyM (Entry AcntID (f Rational) TagID)
|
-> InsertExceptT CurrencyM (Entry AcntID (Deferred Rational) TagID)
|
||||||
resolveEntry f cur r s@Entry {eAcnt, eValue} = do
|
resolveEntry cur r s@Entry {eAcnt, eValue} = do
|
||||||
m <- ask
|
m <- ask
|
||||||
liftInner $ combineErrorM acntRes valRes $ \a v -> do
|
liftInner $ combineErrorM acntRes valRes $ \a v -> do
|
||||||
v' <- mapM (roundPrecisionCur cur m) v
|
v' <- mapM (roundPrecisionCur cur m) v
|
||||||
return $ s {eAcnt = a, eValue = v'}
|
return $ s {eAcnt = a, eValue = v'}
|
||||||
where
|
where
|
||||||
acntRes = resolveAcnt r eAcnt
|
acntRes = resolveAcnt r eAcnt
|
||||||
valRes = f r eValue
|
valRes = resolveValue 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
|
-- curRes = resolveCurrency r eCurrency
|
||||||
|
|
||||||
|
@ -597,21 +556,19 @@ mapErrorsIO f xs = mapM go $ enumTraversable xs
|
||||||
collectErrorsIO :: (Traversable t, MonadUnliftIO m) => t (m a) -> m (t a)
|
collectErrorsIO :: (Traversable t, MonadUnliftIO m) => t (m a) -> m (t a)
|
||||||
collectErrorsIO = mapErrorsIO id
|
collectErrorsIO = mapErrorsIO id
|
||||||
|
|
||||||
resolveFromValue :: TxRecord -> EntryNumGetter -> InsertExcept (Deferred Double)
|
resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept (Deferred Double)
|
||||||
resolveFromValue r = fmap (uncurry Deferred) . resolveValue r
|
|
||||||
|
|
||||||
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
|
resolveValue TxRecord {trOther, trAmount} s = case s of
|
||||||
(LookupN t) -> (False,) <$> (readDouble =<< lookupErr EntryValField t trOther)
|
(LookupN t) -> Deferred False <$> (readDouble =<< lookupErr EntryValField t trOther)
|
||||||
(ConstN c) -> return (False, c)
|
(ConstN c) -> return $ Deferred False c
|
||||||
AmountN m -> return $ (False,) <$> (* m) $ fromRational trAmount
|
AmountN m -> return $ Deferred False $ (* m) $ fromRational trAmount
|
||||||
BalanceN x -> return (True, x)
|
BalanceN x -> return $ Deferred True x
|
||||||
|
|
||||||
|
-- -- 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
|
||||||
|
|
||||||
resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text
|
resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text
|
||||||
resolveAcnt = resolveEntryField AcntField
|
resolveAcnt = resolveEntryField AcntField
|
||||||
|
@ -708,7 +665,7 @@ roundPrecisionCur :: CurID -> CurrencyMap -> Double -> InsertExcept Rational
|
||||||
roundPrecisionCur c m x =
|
roundPrecisionCur c m x =
|
||||||
case M.lookup c m of
|
case M.lookup c m of
|
||||||
Just (_, n) -> return $ roundPrecision n x
|
Just (_, n) -> return $ roundPrecision n x
|
||||||
Nothing -> throwError $ InsertException [RoundError c]
|
Nothing -> throwError $ InsertException [undefined]
|
||||||
|
|
||||||
acntPath2Text :: AcntPath -> T.Text
|
acntPath2Text :: AcntPath -> T.Text
|
||||||
acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)
|
acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)
|
||||||
|
@ -786,22 +743,6 @@ showError other = case other of
|
||||||
, singleQuote $ showT next
|
, singleQuote $ showT next
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
(IndexError Entry {eValue = LinkedNumGetter {lngIndex}, eAcnt} day) ->
|
|
||||||
[ T.unwords
|
|
||||||
[ "No credit entry for index"
|
|
||||||
, singleQuote $ showT lngIndex
|
|
||||||
, "for entry with account"
|
|
||||||
, singleQuote eAcnt
|
|
||||||
, "on"
|
|
||||||
, showT day
|
|
||||||
]
|
|
||||||
]
|
|
||||||
(RoundError cur) ->
|
|
||||||
[ T.unwords
|
|
||||||
[ "Could not look up precision for currency"
|
|
||||||
, singleQuote cur
|
|
||||||
]
|
|
||||||
]
|
|
||||||
|
|
||||||
showGregorian_ :: Gregorian -> T.Text
|
showGregorian_ :: Gregorian -> T.Text
|
||||||
showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ showT <$> [gYear, gMonth, gDay]
|
showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ showT <$> [gYear, gMonth, gDay]
|
||||||
|
|
Loading…
Reference in New Issue