WIP allow running balances to be used in history
This commit is contained in:
parent
45df1af534
commit
b2e4ee05e8
|
|
@ -396,15 +396,30 @@ let FieldMatcher_ =
|
|||
|
||||
let FieldMatcher = FieldMatcher_ Text
|
||||
|
||||
let EntryNumGetter =
|
||||
let FromEntryNumGetter =
|
||||
{-
|
||||
Means to get a numeric value from a statement row.
|
||||
|
||||
LookupN: lookup the value from a field
|
||||
ConstN: a constant value
|
||||
AmountN: the value of the 'Amount' column
|
||||
FLookupN: lookup the value from a field
|
||||
FConstN: a constant value
|
||||
FAmountN: the value of the 'Amount' column
|
||||
FBalanceN: the amount required to make the target account reach a balance
|
||||
-}
|
||||
< LookupN : Text | ConstN : Double | AmountN : Double >
|
||||
< FLookupN : Text
|
||||
| FConstN : Double
|
||||
| FAmountN : Double
|
||||
| FBalanceN : Double
|
||||
>
|
||||
|
||||
let ToEntryNumGetter =
|
||||
{-
|
||||
Means to get a numeric value from a statement row.
|
||||
|
||||
TLookupN: lookup the value from a field
|
||||
TConstN: a constant value
|
||||
TAmountN: the value of the 'Amount' column
|
||||
-}
|
||||
< TLookupN : Text | TConstN : Double | TAmountN : Double >
|
||||
|
||||
let EntryTextGetter =
|
||||
{-
|
||||
|
|
@ -477,8 +492,8 @@ let FromEntryGetter =
|
|||
Means for getting an entry from a given row in a statement to apply to the
|
||||
credit side of the transaction.
|
||||
-}
|
||||
{ Type = Entry EntryAcntGetter EntryNumGetter EntryCurGetter TagID
|
||||
, default = { eValue = None EntryNumGetter, eComment = "" }
|
||||
{ Type = Entry EntryAcntGetter FromEntryNumGetter EntryCurGetter TagID
|
||||
, default = { eValue = None FromEntryNumGetter, eComment = "" }
|
||||
}
|
||||
|
||||
let ToEntryGetter =
|
||||
|
|
@ -487,8 +502,8 @@ let ToEntryGetter =
|
|||
debit side of the transaction.
|
||||
-}
|
||||
{ Type =
|
||||
Entry EntryAcntGetter (Optional EntryNumGetter) EntryCurGetter TagID
|
||||
, default = { eValue = None EntryNumGetter, eComment = "" }
|
||||
Entry EntryAcntGetter (Optional ToEntryNumGetter) EntryCurGetter TagID
|
||||
, default = { eValue = None ToEntryNumGetter, eComment = "" }
|
||||
}
|
||||
|
||||
let TxGetter =
|
||||
|
|
@ -1073,7 +1088,8 @@ in { CurID
|
|||
, DateMatcher
|
||||
, FieldMatcher
|
||||
, FieldMatcher_
|
||||
, EntryNumGetter
|
||||
, FromEntryNumGetter
|
||||
, ToEntryNumGetter
|
||||
, Field
|
||||
, FieldMap
|
||||
, Entry
|
||||
|
|
|
|||
|
|
@ -411,6 +411,6 @@ resolveEntry s@Entry {eAcnt, eCurrency, eValue, eTags} = do
|
|||
s
|
||||
{ eAcnt = aid
|
||||
, eCurrency = cid
|
||||
, eValue = eValue * fromIntegral (sign2Int sign)
|
||||
, eValue = fromIntegral (sign2Int sign) * eValue
|
||||
, eTags = tags
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
module Internal.History
|
||||
( splitHistory
|
||||
, insertHistTransfer
|
||||
, readHistTransfer
|
||||
, readHistStmt
|
||||
, insertHistStmt
|
||||
, insertHistory
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -17,6 +17,7 @@ import qualified RIO.ByteString.Lazy as BL
|
|||
import RIO.FilePath
|
||||
import qualified RIO.List as L
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.NonEmpty as NE
|
||||
import qualified RIO.Text as T
|
||||
import RIO.Time
|
||||
import qualified RIO.Vector as V
|
||||
|
|
@ -27,62 +28,70 @@ splitHistory = partitionEithers . fmap go
|
|||
go (HistTransfer x) = Left x
|
||||
go (HistStatement x) = Right x
|
||||
|
||||
insertHistTransfer
|
||||
insertHistory
|
||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||
=> HistTransfer
|
||||
=> [(CommitR, [RawTx])]
|
||||
-> m ()
|
||||
insertHistTransfer
|
||||
insertHistory hs = do
|
||||
bs <- balanceTxs $ concatMap (\(c, xs) -> fmap (c,) xs) hs
|
||||
forM_ (groupKey (\(CommitR h _) -> h) bs) $ \(c, ts) -> do
|
||||
ck <- insert c
|
||||
mapM_ (insertTx ck) ts
|
||||
|
||||
groupKey :: Ord c => (a -> c) -> [(a, b)] -> [(a, [b])]
|
||||
groupKey f = fmap go . NE.groupAllWith (f . fst)
|
||||
where
|
||||
go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
|
||||
|
||||
readHistTransfer
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> HistTransfer
|
||||
-> m (Maybe (CommitR, [RawTx]))
|
||||
readHistTransfer
|
||||
m@Transfer
|
||||
{ transFrom = from
|
||||
, transTo = to
|
||||
, transCurrency = u
|
||||
, transAmounts = amts
|
||||
} = do
|
||||
whenHash CTManual m () $ \c -> do
|
||||
whenHash_ CTManual m $ do
|
||||
bounds <- askDBState kmStatementInterval
|
||||
let precRes = lookupCurrencyPrec u
|
||||
let go Amount {amtWhen, amtValue, amtDesc} = do
|
||||
let dayRes = liftExcept $ expandDatePat bounds amtWhen
|
||||
(days, precision) <- combineError dayRes precRes (,)
|
||||
let tx day = txPair day from to u (roundPrecision precision amtValue) amtDesc
|
||||
keys <- combineErrors $ fmap tx days
|
||||
mapM_ (insertTx c) keys
|
||||
void $ combineErrors $ fmap go amts
|
||||
return $ fmap tx days
|
||||
concat <$> mapErrors go amts
|
||||
|
||||
readHistStmt
|
||||
:: (MonadUnliftIO m, MonadFinance m)
|
||||
=> FilePath
|
||||
-> Statement
|
||||
-> m (Maybe (CommitR, [KeyTx]))
|
||||
-> m (Maybe (CommitR, [RawTx]))
|
||||
readHistStmt root i = whenHash_ CTImport i $ do
|
||||
bs <- readImport root i
|
||||
bounds <- askDBState kmStatementInterval
|
||||
liftIOExceptT $ mapErrors resolveTx $ filter (inDaySpan bounds . txDate) bs
|
||||
|
||||
insertHistStmt :: (MonadSqlQuery m) => CommitR -> [KeyTx] -> m ()
|
||||
insertHistStmt c ks = do
|
||||
ck <- insert c
|
||||
mapM_ (insertTx ck) ks
|
||||
return $ filter (inDaySpan bounds . txDate) bs
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- low-level transaction stuff
|
||||
|
||||
-- TODO tags here?
|
||||
txPair
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> Day
|
||||
:: Day
|
||||
-> AcntID
|
||||
-> AcntID
|
||||
-> CurID
|
||||
-> Rational
|
||||
-> T.Text
|
||||
-> m KeyTx
|
||||
txPair day from to cur val desc = resolveTx tx
|
||||
-> RawTx
|
||||
txPair day from to cur val desc = tx
|
||||
where
|
||||
split a v =
|
||||
Entry
|
||||
{ eAcnt = a
|
||||
, eValue = v
|
||||
, eValue = ConstD v
|
||||
, eComment = ""
|
||||
, eCurrency = cur
|
||||
, eTags = []
|
||||
|
|
@ -109,7 +118,7 @@ insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do
|
|||
-- Statements
|
||||
|
||||
-- TODO this probably won't scale well (pipes?)
|
||||
readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [BalTx]
|
||||
readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [RawTx]
|
||||
readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
|
||||
let ores = compileOptions stmtTxOpts
|
||||
let cres = combineErrors $ compileMatch <$> stmtParsers
|
||||
|
|
@ -155,11 +164,13 @@ parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFm
|
|||
d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
|
||||
return $ Just $ TxRecord d' a e os p
|
||||
|
||||
matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [BalTx]
|
||||
-- TODO need to somehow balance temporally here (like I do in the budget for
|
||||
-- directives that "pay off" a balance)
|
||||
matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [RawTx]
|
||||
matchRecords ms rs = do
|
||||
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
|
||||
case (matched, unmatched, notfound) of
|
||||
(ms_, [], []) -> liftInner $ combineErrors $ fmap balanceTx ms_
|
||||
(ms_, [], []) -> return ms_ -- liftInner $ combineErrors $ fmap balanceTx ms_
|
||||
(_, us, ns) -> throwError $ InsertException [StatementError us ns]
|
||||
|
||||
matchPriorities :: [MatchRe] -> [MatchGroup]
|
||||
|
|
@ -303,12 +314,37 @@ matchNonDates ms = go ([], [], initZipper ms)
|
|||
MatchFail -> (matched, r : unmatched)
|
||||
in go (m, u, resetZipper z') rs
|
||||
|
||||
balanceTx :: RawTx -> InsertExcept BalTx
|
||||
balanceTx t@Tx {txEntries = ss} = do
|
||||
bs <- balanceEntries ss
|
||||
return $ t {txEntries = bs}
|
||||
balanceTxs
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> [(CommitR, RawTx)]
|
||||
-> m [(CommitR, KeyTx)]
|
||||
balanceTxs ts = do
|
||||
bs <- mapM balanceTx $ snd $ L.mapAccumR balanceTxTargets M.empty ts'
|
||||
return $ zip cs bs
|
||||
where
|
||||
(cs, ts') = L.unzip $ L.sortOn (txDate . snd) ts
|
||||
|
||||
balanceEntries :: [RawEntry] -> InsertExcept [BalEntry]
|
||||
balanceTxTargets
|
||||
:: M.Map a Rational
|
||||
-> Tx (Entry a (Deferred Rational) c t)
|
||||
-> (M.Map a Rational, Tx (Entry a (Maybe Rational) c t))
|
||||
balanceTxTargets = undefined
|
||||
|
||||
balanceEntryTargets
|
||||
:: M.Map a Rational
|
||||
-> Entry a (Deferred Rational) c t
|
||||
-> (M.Map a Rational, Entry a (Maybe Rational) c t)
|
||||
balanceEntryTargets = undefined
|
||||
|
||||
balanceTx
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> Tx (Entry AcntID (Maybe Rational) CurID TagID)
|
||||
-> m KeyTx
|
||||
balanceTx t@Tx {txEntries = ss} = do
|
||||
bs <- liftExcept $ balanceEntries ss
|
||||
resolveTx $ t {txEntries = bs}
|
||||
|
||||
balanceEntries :: [Entry AcntID (Maybe Rational) CurID TagID] -> InsertExcept [BalEntry]
|
||||
balanceEntries ss =
|
||||
fmap concat
|
||||
<$> mapM (uncurry bal)
|
||||
|
|
|
|||
|
|
@ -32,7 +32,8 @@ makeHaskellTypesWith
|
|||
, MultipleConstructors "DatePat" "(./dhall/Types.dhall).DatePat"
|
||||
, MultipleConstructors "YMDMatcher" "(./dhall/Types.dhall).YMDMatcher"
|
||||
, MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher"
|
||||
, MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter"
|
||||
, MultipleConstructors "ToEntryNumGetter" "(./dhall/Types.dhall).ToEntryNumGetter"
|
||||
, MultipleConstructors "FromEntryNumGetter" "(./dhall/Types.dhall).FromEntryNumGetter"
|
||||
, MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
|
||||
, MultipleConstructors "BudgetTransferType" "(./dhall/Types.dhall).BudgetTransferType"
|
||||
, MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod"
|
||||
|
|
@ -97,7 +98,8 @@ deriveProduct
|
|||
, "YMDMatcher"
|
||||
, "BudgetCurrency"
|
||||
, "Exchange"
|
||||
, "EntryNumGetter"
|
||||
, "FromEntryNumGetter"
|
||||
, "ToEntryNumGetter"
|
||||
, "TemporalScope"
|
||||
, "SqlConfig"
|
||||
, "PretaxValue"
|
||||
|
|
@ -338,7 +340,9 @@ instance Ord DateMatcher where
|
|||
compare (On d) (In d' _) = compare d d' <> LT
|
||||
compare (In d _) (On d') = compare d d' <> GT
|
||||
|
||||
deriving instance Hashable EntryNumGetter
|
||||
deriving instance Hashable FromEntryNumGetter
|
||||
|
||||
deriving instance Hashable ToEntryNumGetter
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- top level type with fixed account tree to unroll the recursion in the dhall
|
||||
|
|
@ -421,9 +425,9 @@ data History
|
|||
| HistStatement !Statement
|
||||
deriving (Eq, Generic, Hashable, FromDhall)
|
||||
|
||||
type ToEntryGetter = Entry EntryAcnt (Maybe EntryNumGetter) EntryCur TagID
|
||||
type ToEntryGetter = Entry EntryAcnt (Maybe ToEntryNumGetter) EntryCur TagID
|
||||
|
||||
type FromEntryGetter = Entry EntryAcnt EntryNumGetter EntryCur TagID
|
||||
type FromEntryGetter = Entry EntryAcnt FromEntryNumGetter EntryCur TagID
|
||||
|
||||
instance FromDhall ToEntryGetter
|
||||
|
||||
|
|
|
|||
|
|
@ -59,8 +59,12 @@ data DBUpdates = DBUpdates
|
|||
|
||||
type CurrencyM = Reader CurrencyMap
|
||||
|
||||
type DeferredKeyEntry = Entry AccountRId (Deferred Rational) CurrencyRId TagRId
|
||||
|
||||
type KeyEntry = Entry AccountRId Rational CurrencyRId TagRId
|
||||
|
||||
type DeferredKeyTx = Tx DeferredKeyEntry
|
||||
|
||||
type KeyTx = Tx KeyEntry
|
||||
|
||||
type TreeR = Tree ([T.Text], AccountRId)
|
||||
|
|
@ -127,9 +131,12 @@ accountSign IncomeT = Credit
|
|||
accountSign LiabilityT = Credit
|
||||
accountSign EquityT = Credit
|
||||
|
||||
type RawEntry = Entry AcntID (Maybe Rational) CurID TagID
|
||||
data Deferred a = ConstD a | Target a | Derive
|
||||
deriving (Show, Functor, Foldable, Traversable)
|
||||
|
||||
type RawFromEntry = Entry AcntID Rational CurID TagID
|
||||
type RawEntry = Entry AcntID (Deferred Rational) CurID TagID
|
||||
|
||||
-- type RawFromEntry = Entry AcntID (Deferred Rational) CurID TagID
|
||||
|
||||
type BalEntry = Entry AcntID Rational CurID TagID
|
||||
|
||||
|
|
@ -172,7 +179,7 @@ data InsertError
|
|||
| ParseError !T.Text
|
||||
| ConversionError !T.Text
|
||||
| LookupError !LookupSuberr !T.Text
|
||||
| BalanceError !BalanceType !CurID ![RawEntry]
|
||||
| BalanceError !BalanceType !CurID ![Entry AcntID (Maybe Rational) CurID TagID]
|
||||
| IncomeError !Day !T.Text !Rational
|
||||
| PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
|
||||
| DaySpanError !Gregorian !(Maybe Gregorian)
|
||||
|
|
|
|||
|
|
@ -319,26 +319,24 @@ toTx sc sa fromEntries toEntries r@TxRecord {trAmount, trDate, trDesc} = do
|
|||
(combineError acntRes curRes (,))
|
||||
(combineError fromRes toRes (,))
|
||||
$ \(a, c) (fs, ts) ->
|
||||
let fromValue = trAmount - sum (fmap eValue fs)
|
||||
fromEntry =
|
||||
let fromEntry =
|
||||
Entry
|
||||
{ eAcnt = a
|
||||
, eCurrency = c
|
||||
, eValue = Just fromValue
|
||||
, eValue = ConstD trAmount
|
||||
, eComment = "" -- TODO actually fill this in
|
||||
, eTags = [] -- TODO what goes here?
|
||||
}
|
||||
in Tx
|
||||
{ txDate = trDate
|
||||
, txDescr = trDesc
|
||||
, txEntries = fromEntry : fmap liftEntry fs ++ ts
|
||||
, txEntries = fromEntry : fs ++ ts
|
||||
}
|
||||
where
|
||||
acntRes = liftInner $ resolveAcnt r sa
|
||||
curRes = liftInner $ resolveCurrency r sc
|
||||
fromRes = combineErrors $ fmap (resolveFromEntry r) fromEntries
|
||||
toRes = combineErrors $ fmap (resolveToEntry r) toEntries
|
||||
liftEntry e = e {eValue = Just $ eValue e}
|
||||
|
||||
valMatches :: ValMatcher -> Rational -> InsertExcept Bool
|
||||
valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
|
||||
|
|
@ -364,20 +362,8 @@ otherMatches dict m = case m of
|
|||
where
|
||||
lookup_ t n = lookupErr (MatchField t) n dict
|
||||
|
||||
resolveFromEntry :: TxRecord -> FromEntryGetter -> InsertExceptT CurrencyM RawFromEntry
|
||||
resolveFromEntry :: TxRecord -> FromEntryGetter -> InsertExceptT CurrencyM RawEntry
|
||||
resolveFromEntry r s@Entry {eAcnt, eValue, eCurrency} = do
|
||||
m <- ask
|
||||
liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
|
||||
v' <- roundPrecisionCur c m v
|
||||
return $ s {eAcnt = a, eValue = v', eCurrency = c}
|
||||
where
|
||||
acntRes = resolveAcnt r eAcnt
|
||||
curRes = resolveCurrency r eCurrency
|
||||
valRes = resolveValue r eValue
|
||||
|
||||
-- TODO wet code (kinda, not sure if it's worth combining with above)
|
||||
resolveToEntry :: TxRecord -> ToEntryGetter -> InsertExceptT CurrencyM RawEntry
|
||||
resolveToEntry r s@Entry {eAcnt, eValue, eCurrency} = do
|
||||
m <- ask
|
||||
liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
|
||||
v' <- mapM (roundPrecisionCur c m) v
|
||||
|
|
@ -385,7 +371,19 @@ resolveToEntry r s@Entry {eAcnt, eValue, eCurrency} = do
|
|||
where
|
||||
acntRes = resolveAcnt r eAcnt
|
||||
curRes = resolveCurrency r eCurrency
|
||||
valRes = mapM (resolveValue r) eValue
|
||||
valRes = resolveFromValue r eValue
|
||||
|
||||
-- TODO wet code (kinda, not sure if it's worth combining with above)
|
||||
resolveToEntry :: TxRecord -> ToEntryGetter -> InsertExceptT CurrencyM RawEntry
|
||||
resolveToEntry r s@Entry {eAcnt, eValue, eCurrency} = do
|
||||
m <- ask
|
||||
liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
|
||||
v' <- mapM (roundPrecisionCur c m) v
|
||||
return $ s {eAcnt = a, eValue = maybe Derive Target v', eCurrency = c}
|
||||
where
|
||||
acntRes = resolveAcnt r eAcnt
|
||||
curRes = resolveCurrency r eCurrency
|
||||
valRes = mapM (resolveToValue r) eValue
|
||||
|
||||
liftInner :: Monad m => ExceptT e Identity a -> ExceptT e m a
|
||||
liftInner = mapExceptT (return . runIdentity)
|
||||
|
|
@ -470,11 +468,19 @@ mapErrorsIO f xs = do
|
|||
collectErrorsIO :: MonadUnliftIO m => [m a] -> m [a]
|
||||
collectErrorsIO = mapErrorsIO id
|
||||
|
||||
resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept Double
|
||||
resolveValue TxRecord {trOther, trAmount} s = case s of
|
||||
(LookupN t) -> readDouble =<< lookupErr EntryValField t trOther
|
||||
(ConstN c) -> return c
|
||||
AmountN m -> return $ (* m) $ fromRational trAmount
|
||||
resolveFromValue :: TxRecord -> FromEntryNumGetter -> InsertExcept (Deferred Double)
|
||||
resolveFromValue TxRecord {trOther, trAmount} s = case s of
|
||||
(FLookupN t) -> ConstD <$> (readDouble =<< lookupErr EntryValField t trOther)
|
||||
(FConstN c) -> return $ ConstD c
|
||||
FAmountN m -> return $ ConstD $ (* m) $ fromRational trAmount
|
||||
FBalanceN x -> return $ Target 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 = resolveEntryField AcntField
|
||||
|
|
@ -750,7 +756,7 @@ showMatchOther (Val (Field f mv)) =
|
|||
, singleQuote $ fromMaybe "*" $ showValMatcher mv
|
||||
]
|
||||
|
||||
showEntry :: RawEntry -> T.Text
|
||||
showEntry :: Entry AcntID (Maybe Rational) CurID TagID -> T.Text
|
||||
showEntry Entry {eAcnt, eValue, eComment} =
|
||||
keyVals
|
||||
[ ("account", eAcnt)
|
||||
|
|
|
|||
Loading…
Reference in New Issue