WIP balance transactions in two different ways

This commit is contained in:
Nathan Dwarshuis 2023-07-03 20:27:52 -04:00
parent d5761c75ed
commit bae847d9f3
7 changed files with 521 additions and 342 deletions

View File

@ -180,10 +180,13 @@ runSync c = do
hSs' <- mapErrorsIO (readHistStmt root) hSs
hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs
bTs <- liftIOExceptT $ mapErrors readBudget $ budget config
-- lift $ print hTs'
return $ second concat $ partitionEithers $ hSs' ++ hTs' ++ bTs
-- Update the DB.
runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
-- NOTE this must come first (unless we defer foreign keys)
updateDBState updates
res <- runExceptT $ do
-- TODO taking out the hash is dumb
(rs, ues) <- readUpdates $ fmap commitRHash rus
@ -193,7 +196,6 @@ runSync c = do
-- whatever error is encountered above in an IO context, but the first
-- thrown error should be caught despite possibly needing to be rerun
rerunnableIO $ fromEither res
updateDBState updates -- TODO this will only work if foreign keys are deferred
where
root = takeDirectory c
err (InsertException es) = do

View File

@ -143,12 +143,14 @@ readIncome
incCurrency
"balance after deductions"
(fromRational balance)
()
-- TODO make this into one large tx?
allos <- mapErrors (allo2Trans tc day incFrom) (pre ++ tax ++ post)
let bal =
Tx
{ txCommit = tc
, txDate = day
, txPrimary = primary
, txPrimary = Left primary
, txOther = []
, txDescr = "balance after deductions"
}
@ -264,12 +266,12 @@ allo2Trans
-> m (Tx TxCommit)
allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} = do
-- TODO double here?
p <- entryPair from faTo faCur faDesc (fromRational faValue)
p <- entryPair from faTo faCur faDesc (fromRational faValue) ()
return
Tx
{ txCommit = meta
, txDate = day
, txPrimary = p
, txPrimary = Left p
, txOther = []
, txDescr = faDesc
}
@ -355,30 +357,36 @@ addShadowTransfers ms = mapErrors go
where
go tx = do
es <- catMaybes <$> mapErrors (fromShadow tx) ms
return $ tx {txOther = es}
return $ tx {txOther = Right <$> es}
fromShadow
:: (MonadInsertError m, MonadFinance m)
=> Tx TxCommit
-> ShadowTransfer
-> m (Maybe (EntrySet AcntID CurrencyPrec TagID Rational (Either Double (EntryValue Rational))))
-> m (Maybe ShadowEntrySet)
fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} = do
res <- liftExcept $ shadowMatches stMatch tx
es <- entryPair_ (\_ v -> Left v) stFrom stTo stCurrency stDesc stRatio
es <- entryPair stFrom stTo stCurrency stDesc stRatio ()
return $ if not res then Nothing else Just es
shadowMatches :: TransferMatcher -> Tx TxCommit -> InsertExcept Bool
shadowMatches TransferMatcher {tmFrom, tmTo, tmDate} Tx {txPrimary, txDate} = do
shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} Tx {txPrimary, txDate} = do
-- NOTE this will only match against the primary entry set since those
-- are what are guaranteed to exist from a transfer
-- valRes <- valMatches tmVal $ esTotalValue $ txPrimary
valRes <- case txPrimary of
Left es -> valMatches tmVal $ esTotalValue es
Right _ -> return True
return $
memberMaybe (eAcnt $ hesPrimary $ esFrom txPrimary) tmFrom
&& memberMaybe (eAcnt $ hesPrimary $ esTo txPrimary) tmTo
memberMaybe fa tmFrom
&& memberMaybe ta tmTo
&& maybe True (`dateMatches` txDate) tmDate
&& valRes
where
-- && valRes
fa = either getAcntFrom getAcntFrom txPrimary
ta = either getAcntTo getAcntTo txPrimary
getAcntFrom = getAcnt esFrom
getAcntTo = getAcnt esTo
getAcnt f = eAcnt . hesPrimary . f
memberMaybe x AcntSet {asList, asInclude} =
(if asInclude then id else not) $ x `elem` asList

View File

@ -13,7 +13,6 @@ module Internal.Database
, whenHash_
, eitherHash
, insertEntry
, resolveEntry
, readUpdates
, insertAll
, updateTx
@ -46,9 +45,8 @@ import RIO hiding (LogFunc, isNothing, on, (^.))
import RIO.List ((\\))
import qualified RIO.List as L
import qualified RIO.Map as M
import qualified RIO.NonEmpty as N
import qualified RIO.NonEmpty as NE
import qualified RIO.Text as T
import qualified RIO.Vector as V
runDB
:: MonadUnliftIO m
@ -246,10 +244,10 @@ paths2IDs =
. fmap (first pathList)
where
pathList (AcntPath t []) = atName t :| []
pathList (AcntPath t ns) = N.reverse $ atName t :| ns
pathList (AcntPath t ns) = NE.reverse $ atName t :| ns
-- none of these errors should fire assuming that input is sorted and unique
trimNames :: [N.NonEmpty T.Text] -> [AcntID]
trimNames :: [NE.NonEmpty T.Text] -> [AcntID]
trimNames = fmap (T.intercalate "_" . reverse) . trimAll 0
where
trimAll _ [] = []
@ -270,10 +268,10 @@ trimNames = fmap (T.intercalate "_" . reverse) . trimAll 0
[] -> [trim i y]
_ -> trimAll (i + 1) (reverse $ y : ys)
in (new, [], reverse next ++ old)
trim i = N.take (i + 1)
trim i = NE.take (i + 1)
err msg = errorWithoutStackTrace $ "Import.Database.Ops.hs: " ++ msg
(!?) :: N.NonEmpty a -> Int -> Maybe a
(!?) :: NE.NonEmpty a -> Int -> Maybe a
xs !? n
| n < 0 = Nothing
-- Definition adapted from GHC.List
@ -410,7 +408,7 @@ eitherHash t o f g = do
let h = hash o
let c = CommitR h t
hs <- askDBState kmNewCommits
if h `elem` hs then Left <$> f c else Right <$> g c
if h `elem` hs then Right <$> g c else Left <$> f c
whenHash_
:: (Hashable a, MonadFinance m)
@ -424,160 +422,184 @@ whenHash_ t o f = do
hs <- askDBState kmNewCommits
if h `elem` hs then Just . (c,) <$> f else return Nothing
insertEntry :: MonadSqlQuery m => TransactionRId -> KeyEntry -> m EntryRId
insertEntry
t
InsertEntry
{ feEntry = Entry {eValue, eTags, eAcnt, eComment}
, feCurrency
, feIndex
, feDeferred
} =
do
k <- insert $ EntryR t feCurrency eAcnt eComment eValue feIndex cval ctype deflink
mapM_ (insert_ . TagRelationR k) eTags
return k
where
(cval, ctype, deflink) = case feDeferred of
(Just (EntryLinked index scale)) -> (Just scale, Nothing, Just $ fromIntegral index)
(Just (EntryBalance target)) -> (Just target, Just TBalance, Nothing)
(Just (EntryPercent target)) -> (Just target, Just TPercent, Nothing)
Nothing -> (Nothing, Just TFixed, Nothing)
resolveEntry :: (MonadInsertError m, MonadFinance m) => BalEntry -> m KeyEntry
resolveEntry s@InsertEntry {feEntry = e@Entry {eValue, eTags, eAcnt}, feCurrency} = do
let aRes = lookupAccountKey eAcnt
let cRes = lookupCurrencyKey feCurrency
let sRes = lookupAccountSign eAcnt
let tagRes = combineErrors $ fmap lookupTag eTags
-- TODO correct sign here?
-- TODO lenses would be nice here
combineError (combineError3 aRes cRes sRes (,,)) tagRes $
\(aid, cid, sign) tags ->
s
{ feCurrency = cid
, feEntry = e {eAcnt = aid, eValue = fromIntegral (sign2Int sign) * eValue, eTags = tags}
}
-- resolveEntry :: (MonadInsertError m, MonadFinance m) => BalEntry -> m KeyEntry
-- resolveEntry s@InsertEntry {feEntry = e@Entry {eValue, eTags, eAcnt}, feCurrency} = do
-- let aRes = lookupAccountKey eAcnt
-- let cRes = lookupCurrencyKey feCurrency
-- let sRes = lookupAccountSign eAcnt
-- let tagRes = combineErrors $ fmap lookupTag eTags
-- -- TODO correct sign here?
-- -- TODO lenses would be nice here
-- combineError (combineError3 aRes cRes sRes (,,)) tagRes $
-- \(aid, cid, sign) tags ->
-- s
-- { feCurrency = cid
-- , feEntry = e {eAcnt = aid, eValue = fromIntegral (sign2Int sign) * eValue, eTags = tags}
-- }
readUpdates
:: (MonadInsertError m, MonadSqlQuery m)
=> [Int]
-> m ([ReadEntry], [UpdateEntrySet])
-> m ([ReadEntry], [Either TotalUpdateEntrySet FullUpdateEntrySet])
readUpdates hashes = do
xs <- selectE $ do
(commits :& txs :& entries) <-
(commits :& txs :& entrysets :& entries) <-
E.from
$ E.table @CommitR
`E.innerJoin` E.table @TransactionR
`E.on` (\(c :& t) -> c ^. CommitRId ==. t ^. TransactionRCommit)
`E.innerJoin` E.table @EntrySetR
`E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction)
`E.innerJoin` E.table @EntryR
`E.on` (\(_ :& t :& e) -> t ^. TransactionRId ==. e ^. EntryRTransaction)
`E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset)
E.where_ $ commits ^. CommitRHash `E.in_` E.valList hashes
return
( txs ^. TransactionRDeferred
( entrysets ^. EntrySetRRebalance
,
(
( entrysets ^. EntrySetRId
, txs ^. TransactionRDate
, entrysets ^. EntrySetRCurrency
)
, entries
)
let (toUpdate, toRead) =
bimap unpack (fmap makeRE . unpack) $
L.partition (\(d, _, _) -> E.unValue d) xs
toUpdate' <-
liftExcept $
mapErrors makeUES $
second (fmap snd) <$> groupWith uGroup toUpdate
return (toRead, toUpdate')
)
let (toUpdate, toRead) = L.partition (E.unValue . fst) xs
toUpdate' <- liftExcept $ mapErrors makeUES $ groupKey (\(i, _, _) -> i) (snd <$> toUpdate)
return (makeRE . snd <$> toRead, toUpdate')
where
unpack = fmap (\(_, d, e) -> (E.unValue d, (entityKey e, entityVal e)))
uGroup (day, (_, e)) = (day, entryRCurrency e, entryRTransaction e)
makeUES ((day, cur, _), es) = do
let (froms, tos) =
L.partition ((< 0) . entryRIndex . snd) $
L.sortOn (entryRIndex . snd) es
makeUES ((_, day, curID), es) = do
let res =
bimap NE.nonEmpty NE.nonEmpty $
NE.partition ((< 0) . entryRIndex . snd) $
NE.sortWith (entryRIndex . snd) $
fmap (\e -> (entityKey e, entityVal e)) es
case res of
(Just froms, Just tos) -> do
let tot = sum $ fmap (entryRValue . snd) froms
(from0, fromRO, fromUnk, fromVec) <- splitFrom $ reverse froms
(to0, toRO, toUnk, toLink0, toLinkN) <- splitTo fromVec tos
return
(from0, fromRO, fromUnkVec) <- splitFrom $ NE.reverse froms
(from0', fromUnk, to0, toRO, toUnk) <- splitTo from0 fromUnkVec tos
-- TODO WAP (wet ass programming)
return $ case from0' of
Left x ->
Left $
UpdateEntrySet
{ utDate = day
, utCurrency = cur
, utFrom0 = from0
{ utDate = E.unValue day
, utCurrency = E.unValue curID
, utFrom0 = x
, utTo0 = to0
, utFromRO = fromRO
, utToRO = toRO
, utToUnkLink0 = toLink0
, utPairs = toLinkN
, utFromUnk = fromUnk
, utToUnk = toUnk
, utTotalValue = tot
}
makeRE (d, (_, e)) =
ReadEntry
{ reDate = d
, reCurrency = entryRCurrency e
Right x ->
Right $
UpdateEntrySet
{ utDate = E.unValue day
, utCurrency = E.unValue curID
, utFrom0 = x
, utTo0 = to0
, utFromRO = fromRO
, utToRO = toRO
, utFromUnk = fromUnk
, utToUnk = toUnk
, utTotalValue = ()
}
_ -> throwError undefined
makeRE ((_, day, curID), entry) =
let e = entityVal entry
in ReadEntry
{ reDate = E.unValue day
, reCurrency = E.unValue curID
, reAcnt = entryRAccount e
, reValue = entryRValue e
}
splitFrom
:: [(EntryRId, EntryR)]
-> InsertExcept (UEBlank, [UE_RO], [UEUnk], Vector (Maybe UEUnk))
splitFrom from = do
:: NonEmpty (EntryRId, EntryR)
-> InsertExcept (Either UEBlank (Either UE_RO UEUnk), [UE_RO], [UEUnk])
splitFrom (f0 :| fs) = do
-- ASSUME entries are sorted by index
(primary, rest) <- case from of
((i, e) : xs) -> return (makeUnkUE i e, xs)
_ -> throwError $ InsertException undefined
rest' <- mapErrors splitDeferredValue rest
let idxVec = V.fromList $ fmap (either (const Nothing) Just) rest'
let (ro, toBal) = partitionEithers rest'
return (primary, ro, toBal, idxVec)
-- TODO combine errors here
let f0Res = readDeferredValue f0
let fsRes = mapErrors splitDeferredValue fs
combineErrorM f0Res fsRes $ \f0' fs' -> do
let (ro, unk) = partitionEithers fs'
-- let idxVec = V.fromList $ fmap (either (const Nothing) Just) fs'
return (f0', ro, unk)
splitTo
:: Vector (Maybe UEUnk)
-> [(EntryRId, EntryR)]
:: Either UEBlank (Either UE_RO UEUnk)
-> [UEUnk]
-> NonEmpty (EntryRId, EntryR)
-> InsertExcept
( UEBlank
( Either (UEBlank, [UELink]) (Either UE_RO (UEUnk, [UELink]))
, [(UEUnk, [UELink])]
, UEBlank
, [UE_RO]
, [UEUnk]
, [UELink]
, [(UEUnk, [UELink])]
)
splitTo froms tos = do
splitTo from0 fromUnk (t0 :| ts) = do
-- How to split the credit side of the database transaction in 1024 easy
-- steps:
--
-- 1. ASSUME the entries are sorted by index. Isolate the first as the
-- primary and puke in user's face if list is empty (which it should never
-- be)
(primary, rest) <- case tos of
((i, e) : xs) -> return (makeUnkUE i e, xs)
_ -> throwError $ InsertException undefined
-- 1. Split incoming entries (except primary) into those with links and not
let (unlinked, linked) = partitionEithers $ fmap splitLinked ts
-- 1. Split the entries based on if they have a link
let (unlinked, linked) = partitionEithers $ fmap splitLinked rest
-- 2. Split unlinked based on if they have a balance target
-- 2. For unlinked entries, split into read-only and unknown entries
let unlinkedRes = partitionEithers <$> mapErrors splitDeferredValue unlinked
-- 3. Split paired entries by link == 0 (which are special) or link > 0
let (paired0, pairedN) = second (groupKey id) $ L.partition ((== 0) . fst) linked
let paired0Res = mapErrors (makeLinkUnk . snd) paired0
-- 3. For linked entries, split into those that link to the primary debit
-- entry and not
let (linked0, linkedN) = second (groupKey id) $ L.partition ((== 0) . fst) linked
-- 4. Group linked entries (which now have links > 0) according to the debit
-- entry to which they are linked. If the debit entry cannot be found or
-- if the linked entry has no scale, blow up in user's face. If the
-- debit entry is read-only (signified by Nothing in the 'from' array)
-- then consider the linked entry as another credit read-only entry
let pairedRes = partitionEithers <$> mapErrors splitPaired pairedN
-- 4. For linked entries that don't link to the primary debit entry, split
-- into those that link to an unknown debit entry or not. Those that
-- are not will be read-only and those that are will be collected with
-- their linked debit entry
let linkedRes = zipPaired fromUnk linkedN
combineError3 unlinkedRes paired0Res pairedRes $
\(ro, toBal) paired0' (pairedUnk, pairedRO) ->
(primary, ro ++ concat pairedRO, toBal, paired0', pairedUnk)
-- 5. For entries linked to the primary debit entry, turn them into linked
-- entries (lazily only used when needed later)
let from0Res = mapErrors (makeLinkUnk . snd) linked0
combineErrorM3 from0Res linkedRes unlinkedRes $
-- 6. Depending on the type of primary debit entry we have, add linked
-- entries if it is either an unknown or a blank (to be solved) entry,
-- or turn the remaining linked entries to read-only and add to the other
-- read-only entries
\from0Links (fromUnk', toROLinkedN) (toROUnlinked, toUnk) -> do
let (from0', toROLinked0) = case from0 of
Left blnk -> (Left (blnk, from0Links), [])
Right (Left ro) -> (Right $ Left ro, makeRoUE . snd . snd <$> linked0)
Right (Right unk) -> (Right $ Right (unk, from0Links), [])
return (from0', fromUnk', primary, toROLinked0 ++ toROLinkedN ++ toROUnlinked, toUnk)
where
primary = uncurry makeUnkUE t0
splitLinked t@(_, e) = maybe (Left t) (Right . (,t)) $ entryRCachedLink e
splitPaired (lnk, ts) = case froms V.!? (lnk - 1) of
Just (Just f) -> Left . (f,) <$> mapErrors makeLinkUnk ts
Just Nothing -> return $ Right $ makeRoUE . snd <$> ts
Nothing -> throwError $ InsertException undefined
-- ASSUME from and toLinked are sorted according to index and 'fst' respectively
zipPaired
:: [UEUnk]
-> [(Int, NonEmpty (EntryRId, EntryR))]
-> InsertExcept ([(UEUnk, [UELink])], [UE_RO])
zipPaired = go ([], [])
where
go (facc, tacc) (f : fs) ((ti, tls) : ts)
| ueIndex f == ti = do
tls' <- mapErrors makeLinkUnk tls
go ((f, NE.toList tls') : facc, tacc) fs ts
| otherwise = go ((f, []) : facc, tacc ++ toRO tls) fs ts
go (facc, tacc) fs ts =
return
( reverse facc ++ ((,[]) <$> fs)
, tacc ++ concatMap (toRO . snd) ts
)
toRO = NE.toList . fmap (makeRoUE . snd)
makeLinkUnk :: (EntryRId, EntryR) -> InsertExcept UELink
makeLinkUnk (k, e) =
maybe
(throwError $ InsertException undefined)
@ -585,13 +607,21 @@ splitTo froms tos = do
$ entryRCachedValue e
splitDeferredValue :: (EntryRId, EntryR) -> InsertExcept (Either UE_RO UEUnk)
splitDeferredValue (k, e) = case (entryRCachedValue e, entryRCachedType e) of
(Nothing, Just TFixed) -> return $ Left $ makeRoUE e
splitDeferredValue p = do
res <- readDeferredValue p
case res of
Left _ -> throwError $ InsertException undefined
Right x -> return x
readDeferredValue :: (EntryRId, EntryR) -> InsertExcept (Either UEBlank (Either UE_RO UEUnk))
readDeferredValue (k, e) = case (entryRCachedValue e, entryRCachedType e) of
(Nothing, Just TFixed) -> return $ Right $ Left $ makeRoUE e
(Just v, Just TBalance) -> go EVBalance v
(Just v, Just TPercent) -> go EVPercent v
(Nothing, Nothing) -> return $ Left $ makeUnkUE k e
_ -> throwError $ InsertException undefined
where
go c = return . Right . fmap c . makeUE k e
go c = return . Right . Right . fmap c . makeUE k e
makeUE :: i -> EntryR -> v -> UpdateEntry i v
makeUE k e v = UpdateEntry k (entryRAccount e) v (entryRIndex e)
@ -618,16 +648,40 @@ insertAll ebs = do
getCommit (BudgetCommit c _) = c
insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m ()
insertTx c InsertTx {itxDate, itxDescr, itxEntries, itxCommit} = do
let anyDeferred = any (isJust . feDeferred) itxEntries
k <- insert $ TransactionR c itxDate itxDescr anyDeferred
mapM_ (go k) itxEntries
insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxCommit} = do
k <- insert $ TransactionR c itxDate itxDescr
mapM_ (uncurry (insertEntrySet k)) $ zip [0 ..] (NE.toList itxEntrySets)
where
go k tx = do
ek <- insertEntry k tx
insertEntrySet tk i InsertEntrySet {iesCurrency, iesFromEntries, iesToEntries} = do
let fs = NE.toList iesFromEntries
let ts = NE.toList iesToEntries
let rebalance = any (isJust . ieDeferred) (fs ++ ts)
esk <- insert $ EntrySetR tk iesCurrency i rebalance
mapM_ (uncurry (go esk)) $ zip [0 ..] ts ++ zip (negate <$> [1 ..]) fs
go k i e = do
ek <- insertEntry k i e
case itxCommit of
BudgetCommit _ name -> insert_ $ BudgetLabelR ek name
_ -> return ()
insertEntry :: MonadSqlQuery m => EntrySetRId -> Int -> KeyEntry -> m EntryRId
insertEntry
k
i
InsertEntry
{ ieEntry = Entry {eValue, eTags, eAcnt, eComment}
, ieDeferred
} =
do
ek <- insert $ EntryR k eAcnt eComment eValue i cval ctype deflink
mapM_ (insert_ . TagRelationR ek) eTags
return ek
where
(cval, ctype, deflink) = case ieDeferred of
(Just (EntryLinked index scale)) -> (Just scale, Nothing, Just $ fromIntegral index)
(Just (EntryBalance target)) -> (Just target, Just TBalance, Nothing)
(Just (EntryPercent target)) -> (Just target, Just TPercent, Nothing)
Nothing -> (Nothing, Just TFixed, Nothing)
updateTx :: MonadSqlQuery m => UEBalanced -> m ()
updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. unStaticValue ueValue]

View File

@ -44,11 +44,15 @@ TransactionR sql=transactions
commit CommitRId OnDeleteCascade
date Day
description T.Text
deferred Bool
deriving Show Eq
EntryR sql=entries
EntrySetR sql=entry_sets
transaction TransactionRId OnDeleteCascade
currency CurrencyRId OnDeleteCascade
index Int
rebalance Bool
deriving Show Eq
EntryR sql=entries
entryset EntrySetRId OnDeleteCascade
account AccountRId OnDeleteCascade
memo T.Text
value Rational

View File

@ -459,7 +459,7 @@ data Statement = Statement
, stmtTxOpts :: !(TxOpts T.Text)
, stmtSkipLines :: !Natural
}
deriving (Eq, Hashable, Generic, FromDhall)
deriving (Eq, Hashable, Generic, FromDhall, Show)
-- | the value of a field in entry (text version)
-- can either be a raw (constant) value, a lookup from the record, or a map

View File

@ -37,6 +37,7 @@ data ConfigHashes = ConfigHashes
type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
data CurrencyPrec = CurrencyPrec {cpID :: !CurrencyRId, cpPrec :: !Natural}
deriving (Show)
type CurrencyMap = M.Map CurID CurrencyPrec
@ -50,6 +51,7 @@ data DBState = DBState
, kmStatementInterval :: !DaySpan
, kmNewCommits :: ![Int]
}
deriving (Show)
data DBUpdates = DBUpdates
{ duOldCommits :: ![Int]
@ -79,7 +81,7 @@ data UpdateEntry i v = UpdateEntry
{ ueID :: !i
, ueAcnt :: !AccountRId
, ueValue :: !v
, ueIndex :: !Int -- TODO this isn't needed for primary entries
, ueIndex :: !Int
}
data CurrencyRound = CurrencyRound CurID Natural
@ -107,32 +109,27 @@ type UE_RO = UpdateEntry () StaticValue
type UEBalanced = UpdateEntry EntryRId StaticValue
data UpdateEntrySet = UpdateEntrySet
{ utFrom0 :: !UEBlank
data UpdateEntrySet f t = UpdateEntrySet
{ utFrom0 :: !f
, utTo0 :: !UEBlank
, utPairs :: ![(UEUnk, [UELink])]
, utFromUnk :: ![UEUnk]
, utFromUnk :: ![(UEUnk, [UELink])]
, utToUnk :: ![UEUnk]
, utToUnkLink0 :: ![UELink]
, utFromRO :: ![UE_RO]
, utToRO :: ![UE_RO]
, utCurrency :: !CurrencyRId
, utDate :: !Day
, utTotalValue :: !Rational
, utTotalValue :: !t
}
type TotalUpdateEntrySet = UpdateEntrySet (UEBlank, [UELink]) Rational
type FullUpdateEntrySet = UpdateEntrySet (Either UE_RO (UEUnk, [UELink])) ()
data EntryBin
= ToUpdate UpdateEntrySet
= ToUpdate (Either TotalUpdateEntrySet FullUpdateEntrySet)
| ToRead ReadEntry
| ToInsert (Tx TxCommit)
data InsertEntry a c t = InsertEntry
{ feCurrency :: !c
, feIndex :: !Int
, feDeferred :: !(Maybe DBDeferred)
, feEntry :: !(Entry a Rational t)
}
type KeyEntry = InsertEntry AccountRId CurrencyRId TagRId
type BalEntry = InsertEntry AcntID CurID TagID
@ -206,49 +203,75 @@ accountSign IncomeT = Credit
accountSign LiabilityT = Credit
accountSign EquityT = Credit
data HalfEntrySet a c t v = HalfEntrySet
{ hesPrimary :: !(Entry a () t)
, hesOther :: ![Entry a v t]
data HalfEntrySet v0 vN = HalfEntrySet
{ hesPrimary :: !(Entry AcntID v0 TagID)
, hesOther :: ![Entry AcntID vN TagID]
}
deriving (Show)
data EntrySet a c t v v' = EntrySet
{ esTotalValue :: !v'
, esCurrency :: !c
, esFrom :: !(HalfEntrySet a c t (EntryValue v))
, esTo :: !(HalfEntrySet a c t (LinkDeferred v))
data EntrySet v0 vp0 vpN vtN = EntrySet
{ esTotalValue :: !v0
, esCurrency :: !CurrencyPrec
, esFrom :: !(HalfEntrySet vp0 vpN)
, esTo :: !(HalfEntrySet () vtN)
}
deriving (Show)
data TxCommit = HistoryCommit CommitR | BudgetCommit CommitR T.Text deriving (Eq, Ord)
type TotalEntrySet v0 vpN vtN = EntrySet v0 () vpN vtN
type FullEntrySet vp0 vpN vtN = EntrySet () vp0 vpN vtN
type PrimaryEntrySet =
TotalEntrySet
Rational
(EntryValue Rational)
(LinkDeferred Rational)
type SecondayEntrySet =
FullEntrySet
(EntryValue Rational)
(EntryValue Rational)
(LinkDeferred Rational)
type TransferEntrySet = SecondayEntrySet
type ShadowEntrySet =
TotalEntrySet
Double
(EntryValue Rational)
(LinkDeferred Rational)
data TxCommit = HistoryCommit CommitR | BudgetCommit CommitR T.Text
deriving (Eq, Ord, Show)
data Tx k = Tx
{ txDescr :: !T.Text
, txDate :: !Day
, txPrimary :: !(EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational))
, txOther :: ![EntrySet AcntID CurrencyPrec TagID Rational (Either Double (EntryValue Rational))]
, txPrimary :: !(Either PrimaryEntrySet TransferEntrySet)
, txOther :: ![Either SecondayEntrySet ShadowEntrySet]
, txCommit :: !k
}
deriving (Generic)
deriving (Generic, Show)
data InsertEntry a c t = InsertEntry
{ ieDeferred :: !(Maybe DBDeferred)
, ieEntry :: !(Entry a Rational t)
}
data InsertEntrySet = InsertEntrySet
{ iesCurrency :: !CurrencyRId
, iesFromEntries :: !(NonEmpty (InsertEntry AccountRId CurrencyRId TagRId))
, iesToEntries :: !(NonEmpty (InsertEntry AccountRId CurrencyRId TagRId))
}
data InsertTx = InsertTx
{ itxDescr :: !T.Text
, itxDate :: !Day
, itxEntries :: ![InsertEntry AccountRId CurrencyRId TagRId]
, itxEntrySets :: !(NonEmpty InsertEntrySet)
, itxCommit :: !TxCommit
}
deriving (Generic)
type DeferredEntrySet = EntrySet AcntID CurrencyPrec TagID Rational
type BalEntrySet = EntrySet AcntID CurID TagID Rational
type KeyEntrySet = EntrySet AccountRId CurrencyRId TagRId Rational
-- type DeferredTx = Tx [DeferredEntrySet]
-- type BalTx = InsertTx [BalEntry]
-- type KeyTx = InsertTx [KeyEntry]
data Deferred a = Deferred Bool a
deriving (Show, Functor, Foldable, Traversable)

View File

@ -64,7 +64,6 @@ module Internal.Utils
, expandTransfers
, expandTransfer
, entryPair
, entryPair_
)
where
@ -334,20 +333,21 @@ toTx
, txDescr = trDesc
, txCommit = ()
, txPrimary =
Left $
EntrySet
{ esTotalValue = EntryValue TFixed $ roundPrecisionCur cur $ tgScale * fromRational trAmount
{ esTotalValue = roundPrecisionCur cur $ tgScale * fromRational trAmount
, esCurrency = cur
, esFrom = f
, esTo = t
}
, txOther = ss
, txOther = fmap Left ss
}
where
curRes = do
m <- askDBState kmCurrency
cur <- liftInner $ resolveCurrency m r tgCurrency
let fromRes = liftInner $ resolveHalfEntry resolveFromValue cur r tgFrom
let toRes = liftInner $ resolveHalfEntry resolveToValue cur r tgTo
let fromRes = liftInner $ resolveHalfEntry resolveFromValue cur r () tgFrom
let toRes = liftInner $ resolveHalfEntry resolveToValue cur r () tgTo
combineError fromRes toRes (cur,,)
subRes = mapErrors (resolveSubGetter r) tgOtherEntries
@ -355,16 +355,17 @@ resolveSubGetter
:: MonadFinance m
=> TxRecord
-> TxSubGetter
-> InsertExceptT m (EntrySet AcntID CurrencyPrec TagID Rational (Either Double (EntryValue Rational)))
-> InsertExceptT m SecondayEntrySet
resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
m <- askDBState kmCurrency
cur <- liftInner $ resolveCurrency m r tsgCurrency
let fromRes = resolveHalfEntry resolveFromValue cur r tsgFrom
let toRes = resolveHalfEntry resolveToValue cur r tsgTo
let toRes = resolveHalfEntry resolveToValue cur r () tsgTo
let valRes = liftInner $ fmap (roundPrecisionCur cur) <$> resolveValue r tsgValue
liftInner $ combineError3 fromRes toRes valRes $ \f t v ->
liftInner $ combineErrorM toRes valRes $ \t v -> do
f <- resolveHalfEntry resolveFromValue cur r v tsgFrom
return $
EntrySet
{ esTotalValue = Right v
{ esTotalValue = ()
, esCurrency = cur
, esFrom = f
, esTo = t
@ -375,15 +376,16 @@ resolveHalfEntry
=> (TxRecord -> n -> InsertExcept (f Double))
-> CurrencyPrec
-> TxRecord
-> v
-> TxHalfGetter (EntryGetter n)
-> InsertExcept (HalfEntrySet AcntID CurrencyPrec TagID (f Rational))
resolveHalfEntry f cur r TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} =
-> InsertExcept (HalfEntrySet v (f Rational))
resolveHalfEntry f cur r v TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} =
combineError acntRes esRes $ \a es ->
HalfEntrySet
{ hesPrimary =
Entry
{ eAcnt = a
, eValue = ()
, eValue = v
, eComment = thgComment
, eTags = thgTags
}
@ -913,10 +915,10 @@ unlessLefts_ e f = unlessLefts e (\x -> void (f x) >> return mzero)
-- where
-- go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
groupKey :: Ord c => (a -> c) -> [(a, b)] -> [(a, [b])]
groupKey :: Ord c => (a -> c) -> [(a, b)] -> [(a, NonEmpty b)]
groupKey f = fmap go . NE.groupAllWith (f . fst)
where
go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
go xs@((c, _) :| _) = (c, fmap snd xs)
groupWith :: Ord b => (a -> b) -> [a] -> [(b, [a])]
groupWith f = fmap go . NE.groupAllWith fst . fmap (\x -> (f x, x))
@ -1037,56 +1039,54 @@ balanceTxs ebs =
first concat . partitionEithers . catMaybes
<$> evalStateT (mapErrors go $ L.sortOn binDate ebs) M.empty
where
go (ToUpdate utx) = fmap (Just . Left) $ liftInnerS $ rebalanceEntrySet utx
go (ToUpdate utx) =
fmap (Just . Left) $
liftInnerS $
either rebalanceTotalEntrySet rebalanceFullEntrySet utx
go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do
modify $ mapAdd_ (reAcnt, reCurrency) reValue
return Nothing
go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate}) = do
e <- balanceEntrySet primaryBalance txPrimary
-- TODO this logic is really stupid, I'm balancing the total twice; fix
-- will likely entail making a separate data structure for txs derived
-- from transfers vs statements
let etot = sum $ eValue . feEntry <$> filter ((< 0) . feIndex) e
es <- mapErrors (balanceEntrySet (secondaryBalance etot)) txOther
e <- either balancePrimaryEntrySet balanceSecondaryEntrySet txPrimary
let tot = sum $ fmap (eValue . ieEntry) $ NE.toList $ iesFromEntries e
es <- mapErrors (either balanceSecondaryEntrySet (balancePrimaryEntrySet . fromShadow tot)) txOther
let tx =
InsertTx
{ itxDescr = txDescr
, itxDate = txDate
, itxEntries = concat $ e : es
, itxEntrySets = e :| es
, itxCommit = txCommit
}
return $ Just $ Right tx
primaryBalance Entry {eAcnt} c (EntryValue t v) = findBalance eAcnt c t v
secondaryBalance tot Entry {eAcnt} c val = case val of
Right (EntryValue t v) -> findBalance eAcnt c t v
Left v -> return $ toRational v * tot
fromShadow tot e@EntrySet {esTotalValue} = e {esTotalValue = tot * toRational esTotalValue}
binDate :: EntryBin -> Day
binDate (ToUpdate UpdateEntrySet {utDate}) = utDate
binDate (ToUpdate (Right UpdateEntrySet {utDate})) = utDate
binDate (ToUpdate (Left UpdateEntrySet {utDate})) = utDate
binDate (ToRead ReadEntry {reDate}) = reDate
binDate (ToInsert Tx {txDate}) = txDate
type EntryBals = M.Map (AccountRId, CurrencyRId) Rational
data UpdateEntryType a
data UpdateEntryType a b
= UET_ReadOnly UE_RO
| UET_Unk UEUnk
| UET_Linked a
| UET_Unk a
| UET_Linked b
-- TODO make sure new values are rounded properly here
rebalanceEntrySet :: UpdateEntrySet -> State EntryBals [UEBalanced]
rebalanceEntrySet
rebalanceTotalEntrySet :: TotalUpdateEntrySet -> State EntryBals [UEBalanced]
rebalanceTotalEntrySet
UpdateEntrySet
{ utFrom0
{ utFrom0 = (f0, f0links)
, utTo0
, utPairs
, utFromUnk
, -- , utPairs
utFromUnk
, utToUnk
, utFromRO
, utToRO
, utCurrency
, utToUnkLink0
, utTotalValue
, -- , utToUnkLink0
utTotalValue
} =
do
(f0val, (tpairs, fs)) <-
@ -1094,10 +1094,9 @@ rebalanceEntrySet
foldM goFrom (utTotalValue, []) $
L.sortOn idx $
(UET_ReadOnly <$> utFromRO)
++ (UET_Unk <$> utFromUnk)
++ (UET_Linked <$> utPairs)
let f0 = utFrom0 {ueValue = StaticValue f0val}
let tsLink0 = fmap (unlink (-f0val)) utToUnkLink0
++ (UET_Linked <$> utFromUnk)
let f0' = f0 {ueValue = StaticValue f0val}
let tsLink0 = fmap (unlink (-f0val)) f0links
(t0val, tsUnk) <-
fmap (second catMaybes) $
foldM goTo (-utTotalValue, []) $
@ -1106,7 +1105,7 @@ rebalanceEntrySet
++ (UET_Unk <$> utToUnk)
++ (UET_ReadOnly <$> utToRO)
let t0 = utTo0 {ueValue = StaticValue t0val}
return (f0 : fs ++ (t0 : tsUnk))
return (f0' : fs ++ (t0 : tsUnk))
where
project f _ _ (UET_ReadOnly e) = f e
project _ f _ (UET_Unk e) = f e
@ -1149,13 +1148,126 @@ rebalanceEntrySet
return v
unlink v e = e {ueValue = StaticValue $ v * unLinkScale (ueValue e)}
balanceEntrySet
rebalanceFullEntrySet :: FullUpdateEntrySet -> State EntryBals [UEBalanced]
rebalanceFullEntrySet
UpdateEntrySet
{ utFrom0
, utTo0
, -- , utPairs
utFromUnk
, utToUnk
, utFromRO
, utToRO
, utCurrency
-- , utToUnkLink0
} =
do
let (f_ro, f_lnkd) = case utFrom0 of
Left x -> (x : utFromRO, utFromUnk)
Right x -> (utFromRO, x : utFromUnk)
(tpairs, fs) <-
fmap partitionEithers $
foldM goFrom [] $
L.sortOn idx $
(UET_ReadOnly <$> f_ro)
++ (UET_Linked <$> f_lnkd)
tsUnk <-
fmap catMaybes $
foldM goTo [] $
L.sortOn idx2 $
(UET_Linked <$> tpairs)
++ (UET_Unk <$> utToUnk)
++ (UET_ReadOnly <$> utToRO)
let t0val = -(entrySum fs + entrySum tsUnk)
let t0 = utTo0 {ueValue = t0val}
return (fs ++ (t0 : tsUnk))
where
project f _ _ (UET_ReadOnly e) = f e
project _ f _ (UET_Unk e) = f e
project _ _ f (UET_Linked p) = f p
idx = project ueIndex ueIndex (ueIndex . fst)
idx2 = project ueIndex ueIndex ueIndex
-- TODO the sum accumulator thing is kinda awkward
goFrom es (UET_ReadOnly e) = do
_ <- updateFixed e
return es
goFrom esPrev (UET_Unk e) = do
v <- updateUnknown e
return $ Right e {ueValue = StaticValue v} : esPrev
goFrom esPrev (UET_Linked (e0, es)) = do
v <- updateUnknown e0
let e0' = Right $ e0 {ueValue = StaticValue v}
let es' = fmap (Left . unlink (-v)) es
return $ (e0' : es') ++ esPrev
goTo esPrev (UET_ReadOnly e) = do
_ <- updateFixed e
return esPrev
goTo esPrev (UET_Linked e) = do
_ <- updateFixed e
return $ Just e : esPrev
goTo esPrev (UET_Unk e) = do
v <- updateUnknown e
return $ Just e {ueValue = StaticValue v} : esPrev
updateFixed :: UpdateEntry i StaticValue -> State EntryBals Rational
updateFixed e = do
let v = unStaticValue $ ueValue e
modify $ mapAdd_ (ueAcnt e, utCurrency) v
return v
updateUnknown e = do
let key = (ueAcnt e, utCurrency)
curBal <- gets (M.findWithDefault 0 key)
let v = case ueValue e of
EVPercent p -> p * curBal
EVBalance p -> p - curBal
modify $ mapAdd_ key v
return v
unlink v e = e {ueValue = StaticValue $ v * unLinkScale (ueValue e)}
entrySum = sum . fmap ueValue
balanceSecondaryEntrySet
:: (MonadInsertError m, MonadFinance m)
=> (Entry AccountRId AcntSign TagRId -> CurrencyRId -> v -> State EntryBals Rational)
-> DeferredEntrySet v
-> StateT EntryBals m [KeyEntry]
balanceEntrySet
findTot
=> SecondayEntrySet
-> StateT EntryBals m InsertEntrySet
balanceSecondaryEntrySet
EntrySet
{ esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
, esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
, esCurrency = CurrencyPrec {cpID = curID, cpPrec = precision}
} =
do
fs' <- mapErrors resolveAcntAndTags (f0 :| fs)
t0' <- resolveAcntAndTags t0
ts' <- mapErrors resolveAcntAndTags ts
let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a) curID
fs'' <- mapErrors balFromEntry fs'
let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs''
let balToEntry = balanceEntry (balanceLinked fv curID precision) curID
ts'' <- mapErrors balToEntry ts'
-- TODO wet
let (acntID, sign) = eAcnt t0'
let t0Val = -(entrySum (NE.toList fs'') + entrySum ts'')
modify (mapAdd_ (acntID, curID) t0Val)
let t0'' =
InsertEntry
{ ieEntry = t0' {eValue = fromIntegral (sign2Int sign) * t0Val, eAcnt = acntID}
, ieDeferred = Nothing
}
-- TODO don't record index here, just keep them in order and let the
-- insertion function deal with assigning the index
return $
InsertEntrySet
{ iesCurrency = curID
, iesFromEntries = fs''
, iesToEntries = t0'' :| ts''
}
where
entrySum = sum . fmap (eValue . ieEntry)
balancePrimaryEntrySet
:: (MonadInsertError m, MonadFinance m)
=> PrimaryEntrySet
-> StateT EntryBals m InsertEntrySet
balancePrimaryEntrySet
EntrySet
{ esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
, esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
@ -1163,53 +1275,48 @@ balanceEntrySet
, esTotalValue
} =
do
-- 1. Resolve tag and accout ids in primary entries since we (might) need
-- them later to calculate the total value of the transaction.
let f0res = resolveAcntAndTags f0
let t0res = resolveAcntAndTags t0
combineErrorM f0res t0res $ \f0' t0' -> do
-- 2. Compute total value of transaction using the primary debit entry
tot <- liftInnerS $ findTot f0' curID esTotalValue
-- 3. Balance all debit entries (including primary). Note the negative
-- indices, which will signify them to be debit entries when updated
-- later.
let fsres = mapErrors resolveAcntAndTags fs
let tsres = mapErrors resolveAcntAndTags ts
combineErrorM (combineError f0res fsres (,)) (combineError t0res tsres (,)) $
\(f0', fs') (t0', ts') -> do
let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a) curID
fs' <- doEntries balFromEntry curID tot f0' fs (NE.iterate (+ (-1)) (-1))
fs'' <- doEntries balFromEntry curID esTotalValue f0' fs'
-- 4. Build an array of debit values be linked as desired in credit entries
let fv = V.fromList $ fmap (eValue . feEntry) fs'
let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs''
-- 4. Balance credit entries (including primary) analogously.
let balToEntry = balanceEntry (balanceLinked fv curID precision) curID
ts' <- doEntries balToEntry curID (-tot) t0' ts (NE.iterate (+ 1) 0)
return $ fs' ++ ts'
ts'' <- doEntries balToEntry curID (-esTotalValue) t0' ts'
return $
InsertEntrySet
{ iesCurrency = curID
, iesFromEntries = fs''
, iesToEntries = ts''
}
doEntries
:: (MonadInsertError m)
=> (Int -> Entry AcntID v TagID -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId))
=> (Entry (AccountRId, AcntSign) v TagRId -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId))
-> CurrencyRId
-> Rational
-> Entry AccountRId AcntSign TagRId
-> [Entry AcntID v TagID]
-> NonEmpty Int
-> StateT EntryBals m [InsertEntry AccountRId CurrencyRId TagRId]
doEntries f curID tot e es (i0 :| iN) = do
es' <- mapErrors (uncurry f) $ zip iN es
-> Entry (AccountRId, AcntSign) () TagRId
-> [Entry (AccountRId, AcntSign) v TagRId]
-> StateT EntryBals m (NonEmpty (InsertEntry AccountRId CurrencyRId TagRId))
doEntries f curID tot e@Entry {eAcnt = (acntID, sign)} es = do
es' <- mapErrors f es
let e0val = tot - entrySum es'
-- TODO not dry
let s = fromIntegral $ sign2Int (eValue e) -- NOTE hack
modify (mapAdd_ (eAcnt e, curID) tot)
let s = fromIntegral $ sign2Int sign -- NOTE hack
modify (mapAdd_ (acntID, curID) e0val)
let e' =
InsertEntry
{ feEntry = e {eValue = s * e0val}
, feCurrency = curID
, feDeferred = Nothing
, feIndex = i0
{ ieEntry = e {eValue = s * e0val, eAcnt = acntID}
, ieDeferred = Nothing
}
return $ e' : es'
return $ e' :| es'
where
entrySum = sum . fmap (eValue . feEntry)
entrySum = sum . fmap (eValue . ieEntry)
liftInnerS :: Monad m => StateT e Identity a -> StateT e m a
liftInnerS = mapStateT (return . runIdentity)
@ -1248,38 +1355,30 @@ balanceDeferred curID acntID (EntryValue t v) = do
return (newval, d)
balanceEntry
:: (MonadInsertError m, MonadFinance m)
:: (MonadInsertError m)
=> (AccountRId -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
-> CurrencyRId
-> Int
-> Entry AcntID v TagID
-> Entry (AccountRId, AcntSign) v TagRId
-> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId)
balanceEntry f curID idx e@Entry {eValue, eAcnt, eTags} = do
let acntRes = lookupAccount eAcnt
let tagRes = mapErrors lookupTag eTags
combineErrorM acntRes tagRes $ \(acntID, sign, _) tags -> do
balanceEntry f curID e@Entry {eValue, eAcnt = (acntID, sign)} = do
let s = fromIntegral $ sign2Int sign
(newVal, deferred) <- f acntID eValue
modify (mapAdd_ (acntID, curID) newVal)
return $
InsertEntry
{ feEntry = e {eValue = s * newVal, eAcnt = acntID, eTags = tags}
, feCurrency = curID
, feDeferred = deferred
, feIndex = idx
{ ieEntry = e {eValue = s * newVal, eAcnt = acntID}
, ieDeferred = deferred
}
resolveAcntAndTags
:: (MonadInsertError m, MonadFinance m)
=> Entry AcntID v TagID
-> m (Entry AccountRId AcntSign TagRId)
-> m (Entry (AccountRId, AcntSign) v TagRId)
resolveAcntAndTags e@Entry {eAcnt, eTags} = do
let acntRes = lookupAccount eAcnt
let tagRes = mapErrors lookupTag eTags
-- TODO total hack, store account sign in the value field so I don't need to
-- make seperate tuple pair thing to haul it around. Weird, but it works.
combineError acntRes tagRes $
\(acntID, sign, _) tags -> e {eAcnt = acntID, eTags = tags, eValue = sign}
\(acntID, sign, _) tags -> e {eAcnt = (acntID, sign), eTags = tags}
findBalance
:: AccountRId
@ -1310,7 +1409,7 @@ expandTransfer
-> m [Tx TxCommit]
expandTransfer tc bounds Transfer {transAmounts, transTo, transCurrency, transFrom} = do
txs <- mapErrors go transAmounts
return $ filter (inDaySpan bounds . txDate) $ concat txs
return $ concat txs
where
go
Amount
@ -1318,13 +1417,13 @@ expandTransfer tc bounds Transfer {transAmounts, transTo, transCurrency, transFr
, amtValue = TransferValue {tvVal = v, tvType = t}
, amtDesc = desc
} =
withDates pat $ \day -> do
p <- entryPair_ (\_ x -> EntryValue t $ toRational x) transFrom transTo transCurrency desc v
withDates bounds pat $ \day -> do
p <- entryPair transFrom transTo transCurrency desc () (EntryValue t (toRational (-v)))
return
Tx
{ txCommit = tc
, txDate = day
, txPrimary = p
, txPrimary = Right p
, txOther = []
, txDescr = desc
}
@ -1335,43 +1434,32 @@ entryPair
-> TaggedAcnt
-> CurID
-> T.Text
-> Double
-> m (EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational))
entryPair = entryPair_ (fmap (EntryValue TFixed) . roundPrecisionCur)
entryPair_
:: (MonadInsertError m, MonadFinance m)
=> (CurrencyPrec -> v -> v')
-> TaggedAcnt
-> TaggedAcnt
-> CurID
-> T.Text
-> v
-> m (EntrySet AcntID CurrencyPrec TagID Rational v')
entryPair_ f from to_ curid com val = do
-> v0
-> v1
-> m (EntrySet v0 v1 v2 v3)
entryPair (TaggedAcnt fa fts) (TaggedAcnt ta tts) curid com totval val1 = do
cp <- lookupCurrency curid
return $ pair cp from to_ (f cp val)
where
halfEntry :: a -> [t] -> HalfEntrySet a c t v
halfEntry a ts =
HalfEntrySet
{ hesPrimary = Entry {eAcnt = a, eValue = (), eComment = com, eTags = ts}
, hesOther = []
}
pair cp (TaggedAcnt fa fts) (TaggedAcnt ta tts) v =
return $
EntrySet
{ esCurrency = cp
, esTotalValue = v
, esFrom = halfEntry fa fts
, esTo = halfEntry ta tts
, esTotalValue = totval
, esFrom = halfEntry fa fts val1
, esTo = halfEntry ta tts ()
}
where
halfEntry :: AcntID -> [TagID] -> v -> HalfEntrySet v v0
halfEntry a ts v =
HalfEntrySet
{ hesPrimary = Entry {eAcnt = a, eValue = v, eComment = com, eTags = ts}
, hesOther = []
}
withDates
:: (MonadFinance m, MonadInsertError m)
=> DatePat
=> DaySpan
-> DatePat
-> (Day -> m a)
-> m [a]
withDates dp f = do
bounds <- askDBState kmBudgetInterval
withDates bounds dp f = do
days <- liftExcept $ expandDatePat bounds dp
combineErrors $ fmap f days