Compare commits

..

No commits in common. "f3d2c1655e0e757110bef79d49ab8cd390ba4989" and "c2525fb77cfb48e72d4e326c8054042426200b02" have entirely different histories.

6 changed files with 265 additions and 384 deletions

View File

@ -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

View File

@ -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) ->

View File

@ -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

View File

@ -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)

View File

@ -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]

View File

@ -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]