WIP add logic for updating entries and summing read only entries
This commit is contained in:
parent
5697a071ab
commit
05928087b2
|
@ -8,6 +8,7 @@ module Internal.Database
|
||||||
, flattenAcntRoot
|
, flattenAcntRoot
|
||||||
, paths2IDs
|
, paths2IDs
|
||||||
, mkPool
|
, mkPool
|
||||||
|
, whenHash0
|
||||||
, whenHash
|
, whenHash
|
||||||
, whenHash_
|
, whenHash_
|
||||||
, insertEntry
|
, insertEntry
|
||||||
|
@ -380,6 +381,18 @@ whenHash t o def f = do
|
||||||
hs <- askDBState kmNewCommits
|
hs <- askDBState kmNewCommits
|
||||||
if h `elem` hs then f =<< insert (CommitR h t) else return def
|
if h `elem` hs then f =<< insert (CommitR h t) else return def
|
||||||
|
|
||||||
|
whenHash0
|
||||||
|
:: (Hashable a, MonadFinance m)
|
||||||
|
=> ConfigType
|
||||||
|
-> a
|
||||||
|
-> b
|
||||||
|
-> (CommitR -> m b)
|
||||||
|
-> m b
|
||||||
|
whenHash0 t o def f = do
|
||||||
|
let h = hash o
|
||||||
|
hs <- askDBState kmNewCommits
|
||||||
|
if h `elem` hs then f (CommitR h t) else return def
|
||||||
|
|
||||||
whenHash_
|
whenHash_
|
||||||
:: (Hashable a, MonadFinance m)
|
:: (Hashable a, MonadFinance m)
|
||||||
=> ConfigType
|
=> ConfigType
|
||||||
|
|
|
@ -38,21 +38,21 @@ import qualified RIO.Vector as V
|
||||||
readHistTransfer
|
readHistTransfer
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
:: (MonadInsertError m, MonadFinance m)
|
||||||
=> HistTransfer
|
=> HistTransfer
|
||||||
-> m (Maybe (CommitR, [DeferredTx]))
|
-> m [DeferredTx CommitR]
|
||||||
readHistTransfer
|
readHistTransfer
|
||||||
m@Transfer
|
m@Transfer
|
||||||
{ transFrom = from
|
{ transFrom = from
|
||||||
, transTo = to
|
, transTo = to
|
||||||
, transCurrency = u
|
, transCurrency = u
|
||||||
, transAmounts = amts
|
, transAmounts = amts
|
||||||
} = do
|
} =
|
||||||
whenHash_ CTManual m $ do
|
whenHash0 CTManual m [] $ \c -> do
|
||||||
bounds <- askDBState kmStatementInterval
|
bounds <- askDBState kmStatementInterval
|
||||||
let precRes = lookupCurrencyPrec u
|
let precRes = lookupCurrencyPrec u
|
||||||
let go Amount {amtWhen, amtValue, amtDesc} = do
|
let go Amount {amtWhen, amtValue, amtDesc} = do
|
||||||
let dayRes = liftExcept $ expandDatePat bounds amtWhen
|
let dayRes = liftExcept $ expandDatePat bounds amtWhen
|
||||||
(days, precision) <- combineError dayRes precRes (,)
|
(days, precision) <- combineError dayRes precRes (,)
|
||||||
let tx day = txPair day from to u (roundPrecision precision amtValue) amtDesc
|
let tx day = txPair c day from to u (roundPrecision precision amtValue) amtDesc
|
||||||
return $ fmap tx days
|
return $ fmap tx days
|
||||||
concat <$> mapErrors go amts
|
concat <$> mapErrors go amts
|
||||||
|
|
||||||
|
@ -61,15 +61,20 @@ groupKey f = fmap go . NE.groupAllWith (f . fst)
|
||||||
where
|
where
|
||||||
go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
|
go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
|
||||||
|
|
||||||
|
groupWith :: Ord b => (a -> b) -> [a] -> [(b, [a])]
|
||||||
|
groupWith f = fmap go . NE.groupAllWith fst . fmap (\x -> (f x, x))
|
||||||
|
where
|
||||||
|
go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
|
||||||
|
|
||||||
readHistStmt
|
readHistStmt
|
||||||
:: (MonadUnliftIO m, MonadFinance m)
|
:: (MonadUnliftIO m, MonadFinance m)
|
||||||
=> FilePath
|
=> FilePath
|
||||||
-> Statement
|
-> Statement
|
||||||
-> m (Maybe (CommitR, [DeferredTx]))
|
-> m [DeferredTx CommitR]
|
||||||
readHistStmt root i = whenHash_ CTImport i $ do
|
readHistStmt root i = whenHash0 CTImport i [] $ \c -> 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 . txDate) $ fmap (\t -> t {txCommit = c}) bs
|
||||||
|
|
||||||
splitHistory :: [History] -> ([HistTransfer], [Statement])
|
splitHistory :: [History] -> ([HistTransfer], [Statement])
|
||||||
splitHistory = partitionEithers . fmap go
|
splitHistory = partitionEithers . fmap go
|
||||||
|
@ -79,11 +84,11 @@ splitHistory = partitionEithers . fmap go
|
||||||
|
|
||||||
insertHistory
|
insertHistory
|
||||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||||
=> [(CommitR, [DeferredTx])]
|
=> [DeferredTx CommitR]
|
||||||
-> m ()
|
-> m ()
|
||||||
insertHistory hs = do
|
insertHistory hs = do
|
||||||
bs <- balanceTxs $ concatMap (\(c, xs) -> fmap (c,) xs) hs
|
bs <- balanceTxs hs
|
||||||
forM_ (groupKey (\(CommitR h _) -> h) bs) $ \(c, ts) -> do
|
forM_ (groupWith txCommit bs) $ \(c, ts) -> do
|
||||||
ck <- insert c
|
ck <- insert c
|
||||||
mapM_ (insertTx ck) ts
|
mapM_ (insertTx ck) ts
|
||||||
|
|
||||||
|
@ -92,17 +97,19 @@ insertHistory hs = do
|
||||||
|
|
||||||
-- TODO tags here?
|
-- TODO tags here?
|
||||||
txPair
|
txPair
|
||||||
:: Day
|
:: CommitR
|
||||||
|
-> Day
|
||||||
-> AcntID
|
-> AcntID
|
||||||
-> AcntID
|
-> AcntID
|
||||||
-> CurID
|
-> CurID
|
||||||
-> Rational
|
-> Rational
|
||||||
-> T.Text
|
-> T.Text
|
||||||
-> DeferredTx
|
-> DeferredTx CommitR
|
||||||
txPair day from to cur val desc =
|
txPair commit day from to cur val desc =
|
||||||
Tx
|
Tx
|
||||||
{ txDescr = desc
|
{ txDescr = desc
|
||||||
, txDate = day
|
, txDate = day
|
||||||
|
, txCommit = commit
|
||||||
, txEntries =
|
, txEntries =
|
||||||
[ EntrySet
|
[ EntrySet
|
||||||
{ esTotalValue = -val
|
{ esTotalValue = -val
|
||||||
|
@ -121,20 +128,21 @@ txPair day from to cur val desc =
|
||||||
, eTags = []
|
, eTags = []
|
||||||
}
|
}
|
||||||
|
|
||||||
resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx
|
-- resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx CommitR -> m (KeyTx CommitR)
|
||||||
resolveTx t@Tx {txEntries = ss} =
|
-- resolveTx t@Tx {txEntries = ss} =
|
||||||
(\kss -> t {txEntries = kss}) <$> mapErrors resolveEntry ss
|
-- (\kss -> t {txEntries = kss}) <$> mapErrors resolveEntry ss
|
||||||
|
|
||||||
insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m ()
|
insertTx :: MonadSqlQuery m => CommitRId -> (KeyTx CommitR) -> m ()
|
||||||
insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do
|
insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do
|
||||||
k <- insert $ TransactionR c d e
|
let anyDeferred = any (isJust . feDeferred) ss
|
||||||
|
k <- insert $ TransactionR c d e anyDeferred
|
||||||
mapM_ (insertEntry k) ss
|
mapM_ (insertEntry k) ss
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Statements
|
-- Statements
|
||||||
|
|
||||||
-- TODO this probably won't scale well (pipes?)
|
-- TODO this probably won't scale well (pipes?)
|
||||||
readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [DeferredTx]
|
readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [DeferredTx ()]
|
||||||
readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
|
readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
|
||||||
let ores = compileOptions stmtTxOpts
|
let ores = compileOptions stmtTxOpts
|
||||||
let cres = combineErrors $ compileMatch <$> stmtParsers
|
let cres = combineErrors $ compileMatch <$> stmtParsers
|
||||||
|
@ -182,7 +190,7 @@ parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFm
|
||||||
|
|
||||||
-- TODO need to somehow balance temporally here (like I do in the budget for
|
-- TODO need to somehow balance temporally here (like I do in the budget for
|
||||||
-- directives that "pay off" a balance)
|
-- directives that "pay off" a balance)
|
||||||
matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [DeferredTx]
|
matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [DeferredTx ()]
|
||||||
matchRecords ms rs = do
|
matchRecords ms rs = do
|
||||||
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
|
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
|
||||||
case (matched, unmatched, notfound) of
|
case (matched, unmatched, notfound) of
|
||||||
|
@ -243,7 +251,7 @@ zipperSlice f x = go
|
||||||
zipperMatch
|
zipperMatch
|
||||||
:: Unzipped MatchRe
|
:: Unzipped MatchRe
|
||||||
-> TxRecord
|
-> TxRecord
|
||||||
-> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes DeferredTx)
|
-> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes (DeferredTx ()))
|
||||||
zipperMatch (Unzipped bs cs as) x = go [] cs
|
zipperMatch (Unzipped bs cs as) x = go [] cs
|
||||||
where
|
where
|
||||||
go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
|
go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
|
||||||
|
@ -259,7 +267,7 @@ zipperMatch (Unzipped bs cs as) x = go [] cs
|
||||||
zipperMatch'
|
zipperMatch'
|
||||||
:: Zipped MatchRe
|
:: Zipped MatchRe
|
||||||
-> TxRecord
|
-> TxRecord
|
||||||
-> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes DeferredTx)
|
-> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes (DeferredTx ()))
|
||||||
zipperMatch' z x = go z
|
zipperMatch' z x = go z
|
||||||
where
|
where
|
||||||
go (Zipped bs (a : as)) = do
|
go (Zipped bs (a : as)) = do
|
||||||
|
@ -276,7 +284,7 @@ matchDec m = case spTimes m of
|
||||||
Just n -> Just $ m {spTimes = Just $ n - 1}
|
Just n -> Just $ m {spTimes = Just $ n - 1}
|
||||||
Nothing -> Just m
|
Nothing -> Just m
|
||||||
|
|
||||||
matchAll :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx], [TxRecord], [MatchRe])
|
matchAll :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx ()], [TxRecord], [MatchRe])
|
||||||
matchAll = go ([], [])
|
matchAll = go ([], [])
|
||||||
where
|
where
|
||||||
go (matched, unused) gs rs = case (gs, rs) of
|
go (matched, unused) gs rs = case (gs, rs) of
|
||||||
|
@ -286,13 +294,13 @@ matchAll = go ([], [])
|
||||||
(ts, unmatched, us) <- matchGroup g rs
|
(ts, unmatched, us) <- matchGroup g rs
|
||||||
go (ts ++ matched, us ++ unused) gs' unmatched
|
go (ts ++ matched, us ++ unused) gs' unmatched
|
||||||
|
|
||||||
matchGroup :: MatchGroup -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx], [TxRecord], [MatchRe])
|
matchGroup :: MatchGroup -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx ()], [TxRecord], [MatchRe])
|
||||||
matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
|
matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
|
||||||
(md, rest, ud) <- matchDates ds rs
|
(md, rest, ud) <- matchDates ds rs
|
||||||
(mn, unmatched, un) <- matchNonDates ns rest
|
(mn, unmatched, un) <- matchNonDates ns rest
|
||||||
return (md ++ mn, unmatched, filter ((/= Nothing) . spTimes) $ ud ++ un)
|
return (md ++ mn, unmatched, filter ((/= Nothing) . spTimes) $ ud ++ un)
|
||||||
|
|
||||||
matchDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx], [TxRecord], [MatchRe])
|
matchDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx ()], [TxRecord], [MatchRe])
|
||||||
matchDates ms = go ([], [], initZipper ms)
|
matchDates ms = go ([], [], initZipper ms)
|
||||||
where
|
where
|
||||||
go (matched, unmatched, z) [] =
|
go (matched, unmatched, z) [] =
|
||||||
|
@ -313,7 +321,7 @@ matchDates ms = go ([], [], initZipper ms)
|
||||||
go (m, u, z') rs
|
go (m, u, z') rs
|
||||||
findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m
|
findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m
|
||||||
|
|
||||||
matchNonDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx], [TxRecord], [MatchRe])
|
matchNonDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx ()], [TxRecord], [MatchRe])
|
||||||
matchNonDates ms = go ([], [], initZipper ms)
|
matchNonDates ms = go ([], [], initZipper ms)
|
||||||
where
|
where
|
||||||
go (matched, unmatched, z) [] =
|
go (matched, unmatched, z) [] =
|
||||||
|
@ -332,25 +340,96 @@ matchNonDates ms = go ([], [], initZipper ms)
|
||||||
|
|
||||||
balanceTxs
|
balanceTxs
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
:: (MonadInsertError m, MonadFinance m)
|
||||||
=> [(CommitR, DeferredTx)]
|
=> [EntryBin]
|
||||||
-> m [(CommitR, KeyTx)]
|
-> m ([UpdateEntry EntryRId Rational], [KeyTx CommitR])
|
||||||
balanceTxs ts = do
|
balanceTxs es =
|
||||||
keyts <- mapErrors resolveTx =<< evalStateT (mapM go ts') M.empty
|
(first concat . partitionEithers . catMaybes)
|
||||||
return $ zip cs keyts
|
<$> evalStateT (mapM go $ L.sortOn binDate es) M.empty
|
||||||
where
|
where
|
||||||
(cs, ts') = L.unzip $ L.sortOn (txDate . snd) ts
|
go (ToUpdate utx) = (Just . Left) <$> rebalanceEntrySet utx
|
||||||
go t@Tx {txEntries, txDate} =
|
go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do
|
||||||
(\es -> t {txEntries = concat es}) <$> mapM (balanceEntrySet txDate) txEntries
|
modify $ mapAdd_ (reAcnt, reCurrency) reValue
|
||||||
|
return Nothing
|
||||||
|
go (ToInsert (t@Tx {txEntries, txDate})) =
|
||||||
|
(\es -> Just $ Right $ t {txEntries = concat es})
|
||||||
|
<$> mapM (balanceEntrySet txDate) txEntries
|
||||||
|
|
||||||
type EntryBals = M.Map (AcntID, CurID) Rational
|
binDate :: EntryBin -> Day
|
||||||
|
binDate (ToUpdate (UpdateEntrySet {utDate})) = utDate
|
||||||
|
binDate (ToRead ReadEntry {reDate}) = reDate
|
||||||
|
binDate (ToInsert (Tx {txDate})) = txDate
|
||||||
|
|
||||||
|
type EntryBals = M.Map (AccountRId, CurrencyRId) Rational
|
||||||
|
|
||||||
|
data UpdateEntryType a
|
||||||
|
= UEReadOnly (UpdateEntry () Rational)
|
||||||
|
| UEBlank (UpdateEntry EntryRId Rational)
|
||||||
|
| UEPaired (UpdateEntry EntryRId Rational, UpdateEntry EntryRId a)
|
||||||
|
|
||||||
|
rebalanceEntrySet :: UpdateEntrySet -> State EntryBals [UpdateEntry EntryRId Rational]
|
||||||
|
rebalanceEntrySet
|
||||||
|
UpdateEntrySet
|
||||||
|
{ utFrom0
|
||||||
|
, utTo0
|
||||||
|
, utPairs
|
||||||
|
, utFromUnk
|
||||||
|
, utToUnk
|
||||||
|
, utFromRO
|
||||||
|
, utToRO
|
||||||
|
, utCurrency
|
||||||
|
, utTotalValue
|
||||||
|
} =
|
||||||
|
do
|
||||||
|
let fs =
|
||||||
|
L.sortOn index $
|
||||||
|
(UEReadOnly <$> utFromRO)
|
||||||
|
++ (UEBlank <$> utFromUnk)
|
||||||
|
++ (UEPaired <$> utPairs)
|
||||||
|
fs' <- mapM goFrom fs
|
||||||
|
let f0 = utFrom0 {ueValue = utTotalValue - (sum $ fmap value fs')}
|
||||||
|
let (fs'', tpairs) = partitionEithers $ concatMap flatten fs'
|
||||||
|
let ts = (Right <$> tpairs) ++ (Right <$> utToUnk) ++ (Left <$> utToRO)
|
||||||
|
(tsRO, tsUnk) <- partitionEithers <$> mapM goTo ts
|
||||||
|
let t0 = utTo0 {ueValue = utTotalValue - (sum $ (fmap ueValue tsRO) ++ (fmap ueValue tsUnk))}
|
||||||
|
return $ f0 : fs'' ++ t0 : tsUnk
|
||||||
|
where
|
||||||
|
project f _ _ (UEReadOnly e) = f e
|
||||||
|
project _ f _ (UEBlank e) = f e
|
||||||
|
project _ _ f (UEPaired p) = f p
|
||||||
|
index = project ueIndex ueIndex (ueIndex . fst)
|
||||||
|
value = project ueValue ueValue (ueValue . fst)
|
||||||
|
flatten = project (const []) ((: []) . Right) (\(a, b) -> [Right a, Left b])
|
||||||
|
-- TODO the following is wetter than the average groupie
|
||||||
|
goFrom (UEReadOnly e) = do
|
||||||
|
modify $ mapAdd_ (ueAcnt e, utCurrency) (ueValue e)
|
||||||
|
return $ UEReadOnly e
|
||||||
|
goFrom (UEBlank e) = do
|
||||||
|
let key = (ueAcnt e, utCurrency)
|
||||||
|
curBal <- gets (M.findWithDefault 0 key)
|
||||||
|
let newVal = ueValue e - curBal
|
||||||
|
modify $ mapAdd_ key newVal
|
||||||
|
return $ UEBlank $ e {ueValue = newVal}
|
||||||
|
goFrom (UEPaired (e0, e1)) = do
|
||||||
|
let key = (ueAcnt e0, utCurrency)
|
||||||
|
curBal <- gets (M.findWithDefault 0 key)
|
||||||
|
let newVal = ueValue e0 - curBal
|
||||||
|
modify $ mapAdd_ key newVal
|
||||||
|
return $ UEPaired $ (e0 {ueValue = newVal}, e1 {ueValue = -newVal})
|
||||||
|
goTo (Left e) = do
|
||||||
|
modify $ mapAdd_ (ueAcnt e, utCurrency) (ueValue e)
|
||||||
|
return $ Left e
|
||||||
|
goTo (Right e) = do
|
||||||
|
let key = (ueAcnt e, utCurrency)
|
||||||
|
curBal <- gets (M.findWithDefault 0 key)
|
||||||
|
let newVal = ueValue e - curBal
|
||||||
|
modify $ mapAdd_ key newVal
|
||||||
|
return $ Right $ e {ueValue = newVal}
|
||||||
|
|
||||||
-- 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
|
balanceEntrySet
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
:: (MonadInsertError m, MonadFinance m)
|
||||||
=> Day
|
=> Day
|
||||||
-> DeferredEntrySet
|
-> DeferredEntrySet
|
||||||
-> StateT EntryBals m [BalEntry]
|
-> StateT EntryBals m [KeyEntry]
|
||||||
balanceEntrySet
|
balanceEntrySet
|
||||||
day
|
day
|
||||||
EntrySet
|
EntrySet
|
||||||
|
@ -360,123 +439,82 @@ balanceEntrySet
|
||||||
, esTotalValue
|
, esTotalValue
|
||||||
} =
|
} =
|
||||||
do
|
do
|
||||||
fs' <- doEntries fs esTotalValue f0
|
-- get currency first and quit immediately on exception since everything
|
||||||
-- let fs'' = fmap (\(i, e@Entry {eValue}) -> toFull) $ zip [0 ..] fs'
|
-- downstream depends on this
|
||||||
let fv = V.fromList $ fmap eValue fs'
|
(curID, precision) <- lookupCurrency esCurrency
|
||||||
let (lts, dts) = partitionEithers $ splitLinked <$> ts
|
|
||||||
lts' <- lift $ mapErrors (resolveLinked fv esCurrency day) lts
|
|
||||||
ts' <- doEntries (dts ++ lts') (-esTotalValue) t0
|
|
||||||
-- let ts'' = fmap (uncurry toFull) $ zip [0 ..] ts'
|
|
||||||
return $ fs' -- ++ ts''
|
|
||||||
where
|
|
||||||
doEntries es tot e0 = do
|
|
||||||
es' <- liftInnerS $ mapM (uncurry (balanceEntry esCurrency)) $ zip [1 ..] es
|
|
||||||
let val0 = tot - entrySum es'
|
|
||||||
modify $ mapAdd_ (eAcnt e0, esCurrency) val0
|
|
||||||
return $ e0 {eValue = val0} : es'
|
|
||||||
doEntriesTo es tot e0 = do
|
|
||||||
es' <- liftInnerS $ mapM (balanceEntry esCurrency) es
|
|
||||||
let val0 = tot - entrySum es'
|
|
||||||
modify $ mapAdd_ (eAcnt e0, esCurrency) val0
|
|
||||||
return $ e0 {eValue = val0} : es'
|
|
||||||
toFullDebit i e target =
|
|
||||||
FullEntry
|
|
||||||
{ feEntry = e
|
|
||||||
, feCurrency = esCurrency
|
|
||||||
, feIndex = i
|
|
||||||
, feDeferred = EntryBalance target
|
|
||||||
}
|
|
||||||
splitLinked e@Entry {eValue} = case eValue of
|
|
||||||
LinkIndex l -> Left e {eValue = l}
|
|
||||||
LinkDeferred d -> Right e {eValue = d}
|
|
||||||
entrySum = sum . fmap (eValue . feEntry)
|
|
||||||
|
|
||||||
|
-- resolve accounts and balance debit entries since we need an array
|
||||||
|
-- of debit entries for linked credit entries later
|
||||||
|
let balFromEntry = balanceEntry (balanceDeferred curID) curID
|
||||||
|
fs' <- doEntries balFromEntry curID esTotalValue f0 fs (NE.iterate (-1) (-1))
|
||||||
|
let fv = V.fromList $ fmap (eValue . feEntry) fs'
|
||||||
|
|
||||||
|
-- finally resolve credit entries
|
||||||
|
let balToEntry = balanceEntry (balanceLinked fv curID precision) curID
|
||||||
|
ts' <- doEntries balToEntry curID (-esTotalValue) t0 ts (NE.iterate (+ 1) 0)
|
||||||
|
return $ fs' ++ ts'
|
||||||
|
|
||||||
|
doEntries
|
||||||
|
:: (MonadInsertError m, MonadFinance m)
|
||||||
|
=> (Int -> Entry AcntID v TagID -> State EntryBals (FullEntry AccountRId CurrencyRId TagID))
|
||||||
|
-> CurrencyRId
|
||||||
|
-> Rational
|
||||||
|
-> Entry AcntID () TagID
|
||||||
|
-> [Entry AcntID v TagID]
|
||||||
|
-> NonEmpty Int
|
||||||
|
-> StateT EntryBals m [FullEntry AccountRId CurrencyRId TagID]
|
||||||
|
doEntries f curID tot e es (i0 :| iN) = do
|
||||||
|
es' <- liftInnerS $ mapM (uncurry f) $ zip iN es
|
||||||
|
let val0 = tot - entrySum es'
|
||||||
|
e' <- balanceEntry (\_ _ -> return (val0, Nothing)) curID i0 e
|
||||||
|
return $ e' : es'
|
||||||
|
where
|
||||||
|
entrySum = sum . fmap (eValue . feEntry)
|
||||||
|
|
||||||
|
liftInnerS :: Monad m => StateT e Identity a -> StateT e m a
|
||||||
liftInnerS = mapStateT (return . runIdentity)
|
liftInnerS = mapStateT (return . runIdentity)
|
||||||
|
|
||||||
resolveCreditEntry
|
balanceLinked
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
:: Vector Rational
|
||||||
=> Vector Rational
|
-> CurrencyRId
|
||||||
-> CurID
|
-> Natural
|
||||||
-> Day
|
-> AccountRId
|
||||||
-> Int
|
-> LinkDeferred Rational
|
||||||
-> Entry AcntID LinkedNumGetter TagID
|
-> StateT EntryBals Identity (Rational, Maybe DBDeferred)
|
||||||
-> m (FullEntry AcntID CurID TagID)
|
balanceLinked from curID precision acntID lg = case lg of
|
||||||
resolveCreditEntry from cur day index e@Entry {eValue} = do
|
(LinkIndex g@LinkedNumGetter {lngIndex, lngScale}) -> do
|
||||||
undefined
|
let res = fmap (go lngScale) $ from V.!? fromIntegral lngIndex
|
||||||
|
case res of
|
||||||
resolveLinked
|
Just v -> return $ (v, Just $ EntryLinked lngIndex $ toRational lngScale)
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
Nothing -> throwError undefined
|
||||||
=> Vector Rational
|
(LinkDeferred d) -> balanceDeferred curID acntID d
|
||||||
-> 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'}
|
|
||||||
|
|
||||||
unlinkGetter
|
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
|
||||||
=> Vector Rational
|
|
||||||
-> CurID
|
|
||||||
-> LinkedNumGetter
|
|
||||||
-> m (Maybe Rational)
|
|
||||||
unlinkGetter from cur LinkedNumGetter {lngIndex, lngScale} = do
|
|
||||||
curMap <- askDBState kmCurrency
|
|
||||||
maybe (return Nothing) (go curMap) $ from V.!? fromIntegral lngIndex
|
|
||||||
where
|
where
|
||||||
go m = fmap Just . liftExcept . roundPrecisionCur cur m . (* lngScale) . fromRational
|
go s = roundPrecision precision . (* s) . fromRational
|
||||||
|
|
||||||
balanceFromEntry
|
balanceDeferred
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
:: CurrencyRId
|
||||||
=> CurID
|
-> AccountRId
|
||||||
-> Int
|
|
||||||
-> Entry AcntID v TagID
|
|
||||||
-> StateT EntryBals m (FullEntry AcntID CurID TagID)
|
|
||||||
balanceFromEntry = balanceEntry (\a c -> liftInnerS . balanceDeferrred a c)
|
|
||||||
|
|
||||||
balanceDeferrred
|
|
||||||
:: AcntID
|
|
||||||
-> CurID
|
|
||||||
-> Deferred Rational
|
-> Deferred Rational
|
||||||
-> State EntryBals (Rational, Maybe DBDeferred)
|
-> State EntryBals (Rational, Maybe DBDeferred)
|
||||||
balanceDeferrred acntID curID (Deferred toBal v) = do
|
balanceDeferred curID acntID (Deferred toBal v) = do
|
||||||
newval <- findBalance acntID curID toBal v
|
newval <- findBalance acntID curID toBal v
|
||||||
return $ (newval, if toBal then Just (EntryBalance v) else Nothing)
|
return $ (newval, if toBal then Just (EntryBalance v) else Nothing)
|
||||||
|
|
||||||
balanceToEntry
|
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
|
||||||
=> Vector Rational
|
|
||||||
-> Day
|
|
||||||
-> CurID
|
|
||||||
-> Int
|
|
||||||
-> Entry AcntID v TagID
|
|
||||||
-> StateT EntryBals m (FullEntry AcntID CurID TagID)
|
|
||||||
balanceToEntry from day = balanceEntry go
|
|
||||||
where
|
|
||||||
go _ curID (LinkIndex g@LinkedNumGetter {lngIndex, lngScale}) = do
|
|
||||||
res <- unlinkGetter from curID g
|
|
||||||
case res of
|
|
||||||
Just v -> return $ (v, Just $ EntryLinked lngIndex lngScale)
|
|
||||||
Nothing -> throwError undefined
|
|
||||||
go acntID curID (LinkDeferred d) = balanceDeferrred acntID curID d
|
|
||||||
|
|
||||||
balanceEntry
|
balanceEntry
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
:: (MonadInsertError m, MonadFinance m)
|
||||||
=> (AcntID -> CurID -> v -> m (Rational, Maybe DBDeferred))
|
=> (AccountRId -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
|
||||||
-> CurID
|
-> CurrencyRId
|
||||||
-> Int
|
-> Int
|
||||||
-> Entry AcntID v TagID
|
-> Entry AcntID v TagID
|
||||||
-> StateT EntryBals m (FullEntry AcntID CurID TagID)
|
-> StateT EntryBals m (FullEntry AccountRId CurrencyRId TagID)
|
||||||
balanceEntry f curID index e@Entry {eValue, eAcnt} = do
|
balanceEntry f curID index e@Entry {eValue, eAcnt} = do
|
||||||
(newVal, deferred) <- lift $ f eAcnt curID eValue
|
(acntID, sign, _) <- lookupAccount eAcnt
|
||||||
|
let s = fromIntegral $ sign2Int sign
|
||||||
|
(newVal, deferred) <- f acntID eValue
|
||||||
|
modify (mapAdd_ (acntID, curID) newVal)
|
||||||
return $
|
return $
|
||||||
FullEntry
|
FullEntry
|
||||||
{ feEntry = e {eValue = newVal}
|
{ feEntry = e {eValue = s * newVal, eAcnt = acntID}
|
||||||
, feCurrency = curID
|
, feCurrency = curID
|
||||||
, feDeferred = deferred
|
, feDeferred = deferred
|
||||||
, feIndex = index
|
, feIndex = index
|
||||||
|
@ -484,14 +522,10 @@ balanceEntry f curID index e@Entry {eValue, eAcnt} = do
|
||||||
where
|
where
|
||||||
key = (eAcnt, curID)
|
key = (eAcnt, curID)
|
||||||
|
|
||||||
findBalance :: AcntID -> CurID -> Bool -> Rational -> State EntryBals Rational
|
findBalance :: AccountRId -> CurrencyRId -> Bool -> Rational -> State EntryBals Rational
|
||||||
findBalance acnt cur toBal v = do
|
findBalance acnt cur toBal v = do
|
||||||
curBal <- gets (M.findWithDefault 0 key)
|
curBal <- gets (M.findWithDefault 0 (acnt, cur))
|
||||||
let newVal = if toBal then v - curBal else v
|
return $ if toBal then v - curBal else v
|
||||||
modify (mapAdd_ key newVal)
|
|
||||||
return newVal
|
|
||||||
where
|
|
||||||
key = (acnt, cur)
|
|
||||||
|
|
||||||
-- -- reimplementation from future version :/
|
-- -- reimplementation from future version :/
|
||||||
-- mapAccumM
|
-- mapAccumM
|
||||||
|
|
|
@ -63,6 +63,40 @@ type CurrencyM = Reader CurrencyMap
|
||||||
|
|
||||||
data DBDeferred = EntryLinked Natural Rational | EntryBalance Rational
|
data DBDeferred = EntryLinked Natural Rational | EntryBalance Rational
|
||||||
|
|
||||||
|
data ReadEntry = ReadEntry
|
||||||
|
{ reCurrency :: !CurrencyRId
|
||||||
|
, reAcnt :: !AccountRId
|
||||||
|
, reValue :: !Rational
|
||||||
|
, reDate :: !Day
|
||||||
|
}
|
||||||
|
|
||||||
|
data UpdateEntry i v = UpdateEntry
|
||||||
|
{ ueID :: !i
|
||||||
|
, ueAcnt :: !AccountRId
|
||||||
|
, ueValue :: !v
|
||||||
|
, ueIndex :: !Int -- TODO this isn't needed for primary entries
|
||||||
|
}
|
||||||
|
|
||||||
|
data UpdateEntrySet = UpdateEntrySet
|
||||||
|
{ utFrom0 :: !(UpdateEntry EntryRId ())
|
||||||
|
, utTo0 :: !(UpdateEntry EntryRId ())
|
||||||
|
, utPairs :: ![(UpdateEntry EntryRId Rational, UpdateEntry EntryRId ())]
|
||||||
|
, -- for these two, the Rational number is the balance target (not the
|
||||||
|
-- value of the account)
|
||||||
|
utFromUnk :: ![UpdateEntry EntryRId Rational]
|
||||||
|
, utToUnk :: ![UpdateEntry EntryRId Rational]
|
||||||
|
, utFromRO :: ![UpdateEntry () Rational]
|
||||||
|
, utToRO :: ![UpdateEntry () Rational]
|
||||||
|
, utCurrency :: !CurrencyRId
|
||||||
|
, utDate :: !Day
|
||||||
|
, utTotalValue :: !Rational
|
||||||
|
}
|
||||||
|
|
||||||
|
data EntryBin
|
||||||
|
= ToUpdate UpdateEntrySet
|
||||||
|
| ToRead ReadEntry
|
||||||
|
| ToInsert (DeferredTx CommitR)
|
||||||
|
|
||||||
data FullEntry a c t = FullEntry
|
data FullEntry a c t = FullEntry
|
||||||
{ feCurrency :: !c
|
{ feCurrency :: !c
|
||||||
, feIndex :: !Int
|
, feIndex :: !Int
|
||||||
|
@ -131,6 +165,7 @@ data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show)
|
||||||
data AcntSign = Credit | Debit
|
data AcntSign = Credit | Debit
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
|
-- TODO debit should be negative
|
||||||
sign2Int :: AcntSign -> Int
|
sign2Int :: AcntSign -> Int
|
||||||
sign2Int Debit = 1
|
sign2Int Debit = 1
|
||||||
sign2Int Credit = 1
|
sign2Int Credit = 1
|
||||||
|
@ -154,10 +189,11 @@ data EntrySet a c t v = EntrySet
|
||||||
, esTo :: !(HalfEntrySet a c t (LinkDeferred v))
|
, esTo :: !(HalfEntrySet a c t (LinkDeferred v))
|
||||||
}
|
}
|
||||||
|
|
||||||
data Tx e = Tx
|
data Tx e c = Tx
|
||||||
{ txDescr :: !T.Text
|
{ txDescr :: !T.Text
|
||||||
, txDate :: !Day
|
, txDate :: !Day
|
||||||
, txEntries :: !e
|
, txEntries :: !e
|
||||||
|
, txCommit :: !c
|
||||||
}
|
}
|
||||||
deriving (Generic)
|
deriving (Generic)
|
||||||
|
|
||||||
|
|
|
@ -49,9 +49,11 @@ module Internal.Utils
|
||||||
, valMatches
|
, valMatches
|
||||||
, roundPrecision
|
, roundPrecision
|
||||||
, roundPrecisionCur
|
, roundPrecisionCur
|
||||||
|
, lookupAccount
|
||||||
, lookupAccountKey
|
, lookupAccountKey
|
||||||
, lookupAccountSign
|
, lookupAccountSign
|
||||||
, lookupAccountType
|
, lookupAccountType
|
||||||
|
, lookupCurrency
|
||||||
, lookupCurrencyKey
|
, lookupCurrencyKey
|
||||||
, lookupCurrencyPrec
|
, lookupCurrencyPrec
|
||||||
, lookupTag
|
, lookupTag
|
||||||
|
@ -290,7 +292,7 @@ toDaySpan (a, b) = (a, fromIntegral $ diffDays b a - 1)
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- matching
|
-- matching
|
||||||
|
|
||||||
matches :: MatchRe -> TxRecord -> InsertExceptT CurrencyM (MatchRes DeferredTx)
|
matches :: MatchRe -> TxRecord -> InsertExceptT CurrencyM (MatchRes (DeferredTx ()))
|
||||||
matches
|
matches
|
||||||
StatementParser {spTx, spOther, spVal, spDate, spDesc}
|
StatementParser {spTx, spOther, spVal, spDate, spDesc}
|
||||||
r@TxRecord {trDate, trAmount, trDesc, trOther} = do
|
r@TxRecord {trDate, trAmount, trDesc, trOther} = do
|
||||||
|
@ -307,7 +309,7 @@ matches
|
||||||
desc = maybe (return True) (matchMaybe trDesc . snd) spDesc
|
desc = maybe (return True) (matchMaybe trDesc . snd) spDesc
|
||||||
convert tg = MatchPass <$> toTx tg r
|
convert tg = MatchPass <$> toTx tg r
|
||||||
|
|
||||||
toTx :: TxGetter -> TxRecord -> InsertExceptT CurrencyM DeferredTx
|
toTx :: TxGetter -> TxRecord -> InsertExceptT CurrencyM (DeferredTx ())
|
||||||
toTx
|
toTx
|
||||||
TxGetter
|
TxGetter
|
||||||
{ tgFrom
|
{ tgFrom
|
||||||
|
@ -322,6 +324,7 @@ toTx
|
||||||
Tx
|
Tx
|
||||||
{ txDate = trDate
|
{ txDate = trDate
|
||||||
, txDescr = trDesc
|
, txDescr = trDesc
|
||||||
|
, txCommit = ()
|
||||||
, txEntries =
|
, txEntries =
|
||||||
EntrySet
|
EntrySet
|
||||||
{ esTotalValue = v
|
{ esTotalValue = v
|
||||||
|
@ -1090,7 +1093,7 @@ lookupAccountSign = fmap sndOf3 . lookupAccount
|
||||||
lookupAccountType :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntType
|
lookupAccountType :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntType
|
||||||
lookupAccountType = fmap thdOf3 . lookupAccount
|
lookupAccountType = fmap thdOf3 . lookupAccount
|
||||||
|
|
||||||
lookupCurrency :: (MonadInsertError m, MonadFinance m) => T.Text -> m (CurrencyRId, Natural)
|
lookupCurrency :: (MonadInsertError m, MonadFinance m) => CurID -> m (CurrencyRId, Natural)
|
||||||
lookupCurrency = lookupFinance CurField kmCurrency
|
lookupCurrency = lookupFinance CurField kmCurrency
|
||||||
|
|
||||||
lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m CurrencyRId
|
lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m CurrencyRId
|
||||||
|
|
Loading…
Reference in New Issue