WIP balance transactions in two different ways
This commit is contained in:
parent
d5761c75ed
commit
bae847d9f3
|
@ -180,10 +180,13 @@ runSync c = do
|
||||||
hSs' <- mapErrorsIO (readHistStmt root) hSs
|
hSs' <- mapErrorsIO (readHistStmt root) hSs
|
||||||
hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs
|
hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs
|
||||||
bTs <- liftIOExceptT $ mapErrors readBudget $ budget config
|
bTs <- liftIOExceptT $ mapErrors readBudget $ budget config
|
||||||
|
-- lift $ print hTs'
|
||||||
return $ second concat $ partitionEithers $ hSs' ++ hTs' ++ bTs
|
return $ second concat $ partitionEithers $ hSs' ++ hTs' ++ bTs
|
||||||
|
|
||||||
-- Update the DB.
|
-- Update the DB.
|
||||||
runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
|
runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
|
||||||
|
-- NOTE this must come first (unless we defer foreign keys)
|
||||||
|
updateDBState updates
|
||||||
res <- runExceptT $ do
|
res <- runExceptT $ do
|
||||||
-- TODO taking out the hash is dumb
|
-- TODO taking out the hash is dumb
|
||||||
(rs, ues) <- readUpdates $ fmap commitRHash rus
|
(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
|
-- whatever error is encountered above in an IO context, but the first
|
||||||
-- thrown error should be caught despite possibly needing to be rerun
|
-- thrown error should be caught despite possibly needing to be rerun
|
||||||
rerunnableIO $ fromEither res
|
rerunnableIO $ fromEither res
|
||||||
updateDBState updates -- TODO this will only work if foreign keys are deferred
|
|
||||||
where
|
where
|
||||||
root = takeDirectory c
|
root = takeDirectory c
|
||||||
err (InsertException es) = do
|
err (InsertException es) = do
|
||||||
|
|
|
@ -143,12 +143,14 @@ readIncome
|
||||||
incCurrency
|
incCurrency
|
||||||
"balance after deductions"
|
"balance after deductions"
|
||||||
(fromRational balance)
|
(fromRational balance)
|
||||||
|
()
|
||||||
|
-- TODO make this into one large tx?
|
||||||
allos <- mapErrors (allo2Trans tc day incFrom) (pre ++ tax ++ post)
|
allos <- mapErrors (allo2Trans tc day incFrom) (pre ++ tax ++ post)
|
||||||
let bal =
|
let bal =
|
||||||
Tx
|
Tx
|
||||||
{ txCommit = tc
|
{ txCommit = tc
|
||||||
, txDate = day
|
, txDate = day
|
||||||
, txPrimary = primary
|
, txPrimary = Left primary
|
||||||
, txOther = []
|
, txOther = []
|
||||||
, txDescr = "balance after deductions"
|
, txDescr = "balance after deductions"
|
||||||
}
|
}
|
||||||
|
@ -264,12 +266,12 @@ allo2Trans
|
||||||
-> m (Tx TxCommit)
|
-> m (Tx TxCommit)
|
||||||
allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} = do
|
allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} = do
|
||||||
-- TODO double here?
|
-- TODO double here?
|
||||||
p <- entryPair from faTo faCur faDesc (fromRational faValue)
|
p <- entryPair from faTo faCur faDesc (fromRational faValue) ()
|
||||||
return
|
return
|
||||||
Tx
|
Tx
|
||||||
{ txCommit = meta
|
{ txCommit = meta
|
||||||
, txDate = day
|
, txDate = day
|
||||||
, txPrimary = p
|
, txPrimary = Left p
|
||||||
, txOther = []
|
, txOther = []
|
||||||
, txDescr = faDesc
|
, txDescr = faDesc
|
||||||
}
|
}
|
||||||
|
@ -355,30 +357,36 @@ addShadowTransfers ms = mapErrors go
|
||||||
where
|
where
|
||||||
go tx = do
|
go tx = do
|
||||||
es <- catMaybes <$> mapErrors (fromShadow tx) ms
|
es <- catMaybes <$> mapErrors (fromShadow tx) ms
|
||||||
return $ tx {txOther = es}
|
return $ tx {txOther = Right <$> es}
|
||||||
|
|
||||||
fromShadow
|
fromShadow
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
:: (MonadInsertError m, MonadFinance m)
|
||||||
=> Tx TxCommit
|
=> Tx TxCommit
|
||||||
-> ShadowTransfer
|
-> 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
|
fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} = do
|
||||||
res <- liftExcept $ shadowMatches stMatch tx
|
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
|
return $ if not res then Nothing else Just es
|
||||||
|
|
||||||
shadowMatches :: TransferMatcher -> Tx TxCommit -> InsertExcept Bool
|
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
|
-- NOTE this will only match against the primary entry set since those
|
||||||
-- are what are guaranteed to exist from a transfer
|
-- 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 $
|
return $
|
||||||
memberMaybe (eAcnt $ hesPrimary $ esFrom txPrimary) tmFrom
|
memberMaybe fa tmFrom
|
||||||
&& memberMaybe (eAcnt $ hesPrimary $ esTo txPrimary) tmTo
|
&& memberMaybe ta tmTo
|
||||||
&& maybe True (`dateMatches` txDate) tmDate
|
&& maybe True (`dateMatches` txDate) tmDate
|
||||||
|
&& valRes
|
||||||
where
|
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} =
|
memberMaybe x AcntSet {asList, asInclude} =
|
||||||
(if asInclude then id else not) $ x `elem` asList
|
(if asInclude then id else not) $ x `elem` asList
|
||||||
|
|
||||||
|
|
|
@ -13,7 +13,6 @@ module Internal.Database
|
||||||
, whenHash_
|
, whenHash_
|
||||||
, eitherHash
|
, eitherHash
|
||||||
, insertEntry
|
, insertEntry
|
||||||
, resolveEntry
|
|
||||||
, readUpdates
|
, readUpdates
|
||||||
, insertAll
|
, insertAll
|
||||||
, updateTx
|
, updateTx
|
||||||
|
@ -46,9 +45,8 @@ import RIO hiding (LogFunc, isNothing, on, (^.))
|
||||||
import RIO.List ((\\))
|
import RIO.List ((\\))
|
||||||
import qualified RIO.List as L
|
import qualified RIO.List as L
|
||||||
import qualified RIO.Map as M
|
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.Text as T
|
||||||
import qualified RIO.Vector as V
|
|
||||||
|
|
||||||
runDB
|
runDB
|
||||||
:: MonadUnliftIO m
|
:: MonadUnliftIO m
|
||||||
|
@ -246,10 +244,10 @@ paths2IDs =
|
||||||
. fmap (first pathList)
|
. fmap (first pathList)
|
||||||
where
|
where
|
||||||
pathList (AcntPath t []) = atName t :| []
|
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
|
-- 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
|
trimNames = fmap (T.intercalate "_" . reverse) . trimAll 0
|
||||||
where
|
where
|
||||||
trimAll _ [] = []
|
trimAll _ [] = []
|
||||||
|
@ -270,10 +268,10 @@ trimNames = fmap (T.intercalate "_" . reverse) . trimAll 0
|
||||||
[] -> [trim i y]
|
[] -> [trim i y]
|
||||||
_ -> trimAll (i + 1) (reverse $ y : ys)
|
_ -> trimAll (i + 1) (reverse $ y : ys)
|
||||||
in (new, [], reverse next ++ old)
|
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
|
err msg = errorWithoutStackTrace $ "Import.Database.Ops.hs: " ++ msg
|
||||||
|
|
||||||
(!?) :: N.NonEmpty a -> Int -> Maybe a
|
(!?) :: NE.NonEmpty a -> Int -> Maybe a
|
||||||
xs !? n
|
xs !? n
|
||||||
| n < 0 = Nothing
|
| n < 0 = Nothing
|
||||||
-- Definition adapted from GHC.List
|
-- Definition adapted from GHC.List
|
||||||
|
@ -410,7 +408,7 @@ eitherHash t o f g = do
|
||||||
let h = hash o
|
let h = hash o
|
||||||
let c = CommitR h t
|
let c = CommitR h t
|
||||||
hs <- askDBState kmNewCommits
|
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_
|
whenHash_
|
||||||
:: (Hashable a, MonadFinance m)
|
:: (Hashable a, MonadFinance m)
|
||||||
|
@ -424,174 +422,206 @@ whenHash_ t o f = do
|
||||||
hs <- askDBState kmNewCommits
|
hs <- askDBState kmNewCommits
|
||||||
if h `elem` hs then Just . (c,) <$> f else return Nothing
|
if h `elem` hs then Just . (c,) <$> f else return Nothing
|
||||||
|
|
||||||
insertEntry :: MonadSqlQuery m => TransactionRId -> KeyEntry -> m EntryRId
|
-- resolveEntry :: (MonadInsertError m, MonadFinance m) => BalEntry -> m KeyEntry
|
||||||
insertEntry
|
-- resolveEntry s@InsertEntry {feEntry = e@Entry {eValue, eTags, eAcnt}, feCurrency} = do
|
||||||
t
|
-- let aRes = lookupAccountKey eAcnt
|
||||||
InsertEntry
|
-- let cRes = lookupCurrencyKey feCurrency
|
||||||
{ feEntry = Entry {eValue, eTags, eAcnt, eComment}
|
-- let sRes = lookupAccountSign eAcnt
|
||||||
, feCurrency
|
-- let tagRes = combineErrors $ fmap lookupTag eTags
|
||||||
, feIndex
|
-- -- TODO correct sign here?
|
||||||
, feDeferred
|
-- -- TODO lenses would be nice here
|
||||||
} =
|
-- combineError (combineError3 aRes cRes sRes (,,)) tagRes $
|
||||||
do
|
-- \(aid, cid, sign) tags ->
|
||||||
k <- insert $ EntryR t feCurrency eAcnt eComment eValue feIndex cval ctype deflink
|
-- s
|
||||||
mapM_ (insert_ . TagRelationR k) eTags
|
-- { feCurrency = cid
|
||||||
return k
|
-- , feEntry = e {eAcnt = aid, eValue = fromIntegral (sign2Int sign) * eValue, eTags = tags}
|
||||||
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}
|
|
||||||
}
|
|
||||||
|
|
||||||
readUpdates
|
readUpdates
|
||||||
:: (MonadInsertError m, MonadSqlQuery m)
|
:: (MonadInsertError m, MonadSqlQuery m)
|
||||||
=> [Int]
|
=> [Int]
|
||||||
-> m ([ReadEntry], [UpdateEntrySet])
|
-> m ([ReadEntry], [Either TotalUpdateEntrySet FullUpdateEntrySet])
|
||||||
readUpdates hashes = do
|
readUpdates hashes = do
|
||||||
xs <- selectE $ do
|
xs <- selectE $ do
|
||||||
(commits :& txs :& entries) <-
|
(commits :& txs :& entrysets :& entries) <-
|
||||||
E.from
|
E.from
|
||||||
$ E.table @CommitR
|
$ E.table @CommitR
|
||||||
`E.innerJoin` E.table @TransactionR
|
`E.innerJoin` E.table @TransactionR
|
||||||
`E.on` (\(c :& t) -> c ^. CommitRId ==. t ^. TransactionRCommit)
|
`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.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
|
E.where_ $ commits ^. CommitRHash `E.in_` E.valList hashes
|
||||||
return
|
return
|
||||||
( txs ^. TransactionRDeferred
|
( entrysets ^. EntrySetRRebalance
|
||||||
, txs ^. TransactionRDate
|
,
|
||||||
, entries
|
(
|
||||||
|
( entrysets ^. EntrySetRId
|
||||||
|
, txs ^. TransactionRDate
|
||||||
|
, entrysets ^. EntrySetRCurrency
|
||||||
|
)
|
||||||
|
, entries
|
||||||
|
)
|
||||||
)
|
)
|
||||||
let (toUpdate, toRead) =
|
let (toUpdate, toRead) = L.partition (E.unValue . fst) xs
|
||||||
bimap unpack (fmap makeRE . unpack) $
|
toUpdate' <- liftExcept $ mapErrors makeUES $ groupKey (\(i, _, _) -> i) (snd <$> toUpdate)
|
||||||
L.partition (\(d, _, _) -> E.unValue d) xs
|
return (makeRE . snd <$> toRead, toUpdate')
|
||||||
toUpdate' <-
|
|
||||||
liftExcept $
|
|
||||||
mapErrors makeUES $
|
|
||||||
second (fmap snd) <$> groupWith uGroup toUpdate
|
|
||||||
return (toRead, toUpdate')
|
|
||||||
where
|
where
|
||||||
unpack = fmap (\(_, d, e) -> (E.unValue d, (entityKey e, entityVal e)))
|
makeUES ((_, day, curID), es) = do
|
||||||
uGroup (day, (_, e)) = (day, entryRCurrency e, entryRTransaction e)
|
let res =
|
||||||
makeUES ((day, cur, _), es) = do
|
bimap NE.nonEmpty NE.nonEmpty $
|
||||||
let (froms, tos) =
|
NE.partition ((< 0) . entryRIndex . snd) $
|
||||||
L.partition ((< 0) . entryRIndex . snd) $
|
NE.sortWith (entryRIndex . snd) $
|
||||||
L.sortOn (entryRIndex . snd) es
|
fmap (\e -> (entityKey e, entityVal e)) es
|
||||||
let tot = sum $ fmap (entryRValue . snd) froms
|
case res of
|
||||||
(from0, fromRO, fromUnk, fromVec) <- splitFrom $ reverse froms
|
(Just froms, Just tos) -> do
|
||||||
(to0, toRO, toUnk, toLink0, toLinkN) <- splitTo fromVec tos
|
let tot = sum $ fmap (entryRValue . snd) froms
|
||||||
return
|
(from0, fromRO, fromUnkVec) <- splitFrom $ NE.reverse froms
|
||||||
UpdateEntrySet
|
(from0', fromUnk, to0, toRO, toUnk) <- splitTo from0 fromUnkVec tos
|
||||||
{ utDate = day
|
-- TODO WAP (wet ass programming)
|
||||||
, utCurrency = cur
|
return $ case from0' of
|
||||||
, utFrom0 = from0
|
Left x ->
|
||||||
, utTo0 = to0
|
Left $
|
||||||
, utFromRO = fromRO
|
UpdateEntrySet
|
||||||
, utToRO = toRO
|
{ utDate = E.unValue day
|
||||||
, utToUnkLink0 = toLink0
|
, utCurrency = E.unValue curID
|
||||||
, utPairs = toLinkN
|
, utFrom0 = x
|
||||||
, utFromUnk = fromUnk
|
, utTo0 = to0
|
||||||
, utToUnk = toUnk
|
, utFromRO = fromRO
|
||||||
, utTotalValue = tot
|
, utToRO = toRO
|
||||||
}
|
, utFromUnk = fromUnk
|
||||||
makeRE (d, (_, e)) =
|
, utToUnk = toUnk
|
||||||
ReadEntry
|
, utTotalValue = tot
|
||||||
{ reDate = d
|
}
|
||||||
, reCurrency = entryRCurrency e
|
Right x ->
|
||||||
, reAcnt = entryRAccount e
|
Right $
|
||||||
, reValue = entryRValue e
|
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
|
splitFrom
|
||||||
:: [(EntryRId, EntryR)]
|
:: NonEmpty (EntryRId, EntryR)
|
||||||
-> InsertExcept (UEBlank, [UE_RO], [UEUnk], Vector (Maybe UEUnk))
|
-> InsertExcept (Either UEBlank (Either UE_RO UEUnk), [UE_RO], [UEUnk])
|
||||||
splitFrom from = do
|
splitFrom (f0 :| fs) = do
|
||||||
-- ASSUME entries are sorted by index
|
-- ASSUME entries are sorted by index
|
||||||
(primary, rest) <- case from of
|
-- TODO combine errors here
|
||||||
((i, e) : xs) -> return (makeUnkUE i e, xs)
|
let f0Res = readDeferredValue f0
|
||||||
_ -> throwError $ InsertException undefined
|
let fsRes = mapErrors splitDeferredValue fs
|
||||||
rest' <- mapErrors splitDeferredValue rest
|
combineErrorM f0Res fsRes $ \f0' fs' -> do
|
||||||
let idxVec = V.fromList $ fmap (either (const Nothing) Just) rest'
|
let (ro, unk) = partitionEithers fs'
|
||||||
let (ro, toBal) = partitionEithers rest'
|
-- let idxVec = V.fromList $ fmap (either (const Nothing) Just) fs'
|
||||||
return (primary, ro, toBal, idxVec)
|
return (f0', ro, unk)
|
||||||
|
|
||||||
splitTo
|
splitTo
|
||||||
:: Vector (Maybe UEUnk)
|
:: Either UEBlank (Either UE_RO UEUnk)
|
||||||
-> [(EntryRId, EntryR)]
|
-> [UEUnk]
|
||||||
|
-> NonEmpty (EntryRId, EntryR)
|
||||||
-> InsertExcept
|
-> InsertExcept
|
||||||
( UEBlank
|
( Either (UEBlank, [UELink]) (Either UE_RO (UEUnk, [UELink]))
|
||||||
|
, [(UEUnk, [UELink])]
|
||||||
|
, UEBlank
|
||||||
, [UE_RO]
|
, [UE_RO]
|
||||||
, [UEUnk]
|
, [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
|
-- How to split the credit side of the database transaction in 1024 easy
|
||||||
-- steps:
|
-- steps:
|
||||||
--
|
--
|
||||||
-- 1. ASSUME the entries are sorted by index. Isolate the first as the
|
-- 1. Split incoming entries (except primary) into those with links and not
|
||||||
-- primary and puke in user's face if list is empty (which it should never
|
let (unlinked, linked) = partitionEithers $ fmap splitLinked ts
|
||||||
-- be)
|
|
||||||
(primary, rest) <- case tos of
|
|
||||||
((i, e) : xs) -> return (makeUnkUE i e, xs)
|
|
||||||
_ -> throwError $ InsertException undefined
|
|
||||||
|
|
||||||
-- 1. Split the entries based on if they have a link
|
-- 2. For unlinked entries, split into read-only and unknown entries
|
||||||
let (unlinked, linked) = partitionEithers $ fmap splitLinked rest
|
|
||||||
|
|
||||||
-- 2. Split unlinked based on if they have a balance target
|
|
||||||
let unlinkedRes = partitionEithers <$> mapErrors splitDeferredValue unlinked
|
let unlinkedRes = partitionEithers <$> mapErrors splitDeferredValue unlinked
|
||||||
|
|
||||||
-- 3. Split paired entries by link == 0 (which are special) or link > 0
|
-- 3. For linked entries, split into those that link to the primary debit
|
||||||
let (paired0, pairedN) = second (groupKey id) $ L.partition ((== 0) . fst) linked
|
-- entry and not
|
||||||
let paired0Res = mapErrors (makeLinkUnk . snd) paired0
|
let (linked0, linkedN) = second (groupKey id) $ L.partition ((== 0) . fst) linked
|
||||||
|
|
||||||
-- 4. Group linked entries (which now have links > 0) according to the debit
|
-- 4. For linked entries that don't link to the primary debit entry, split
|
||||||
-- entry to which they are linked. If the debit entry cannot be found or
|
-- into those that link to an unknown debit entry or not. Those that
|
||||||
-- if the linked entry has no scale, blow up in user's face. If the
|
-- are not will be read-only and those that are will be collected with
|
||||||
-- debit entry is read-only (signified by Nothing in the 'from' array)
|
-- their linked debit entry
|
||||||
-- then consider the linked entry as another credit read-only entry
|
let linkedRes = zipPaired fromUnk linkedN
|
||||||
let pairedRes = partitionEithers <$> mapErrors splitPaired pairedN
|
|
||||||
|
|
||||||
combineError3 unlinkedRes paired0Res pairedRes $
|
-- 5. For entries linked to the primary debit entry, turn them into linked
|
||||||
\(ro, toBal) paired0' (pairedUnk, pairedRO) ->
|
-- entries (lazily only used when needed later)
|
||||||
(primary, ro ++ concat pairedRO, toBal, paired0', pairedUnk)
|
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
|
where
|
||||||
|
primary = uncurry makeUnkUE t0
|
||||||
splitLinked t@(_, e) = maybe (Left t) (Right . (,t)) $ entryRCachedLink e
|
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
|
-- ASSUME from and toLinked are sorted according to index and 'fst' respectively
|
||||||
Just Nothing -> return $ Right $ makeRoUE . snd <$> ts
|
zipPaired
|
||||||
Nothing -> throwError $ InsertException undefined
|
:: [UEUnk]
|
||||||
makeLinkUnk (k, e) =
|
-> [(Int, NonEmpty (EntryRId, EntryR))]
|
||||||
maybe
|
-> InsertExcept ([(UEUnk, [UELink])], [UE_RO])
|
||||||
(throwError $ InsertException undefined)
|
zipPaired = go ([], [])
|
||||||
(return . makeUE k e . LinkScale)
|
where
|
||||||
$ entryRCachedValue e
|
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)
|
||||||
|
(return . makeUE k e . LinkScale)
|
||||||
|
$ entryRCachedValue e
|
||||||
|
|
||||||
splitDeferredValue :: (EntryRId, EntryR) -> InsertExcept (Either UE_RO UEUnk)
|
splitDeferredValue :: (EntryRId, EntryR) -> InsertExcept (Either UE_RO UEUnk)
|
||||||
splitDeferredValue (k, e) = case (entryRCachedValue e, entryRCachedType e) of
|
splitDeferredValue p = do
|
||||||
(Nothing, Just TFixed) -> return $ Left $ makeRoUE e
|
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 TBalance) -> go EVBalance v
|
||||||
(Just v, Just TPercent) -> go EVPercent v
|
(Just v, Just TPercent) -> go EVPercent v
|
||||||
|
(Nothing, Nothing) -> return $ Left $ makeUnkUE k e
|
||||||
_ -> throwError $ InsertException undefined
|
_ -> throwError $ InsertException undefined
|
||||||
where
|
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 :: i -> EntryR -> v -> UpdateEntry i v
|
||||||
makeUE k e v = UpdateEntry k (entryRAccount e) v (entryRIndex e)
|
makeUE k e v = UpdateEntry k (entryRAccount e) v (entryRIndex e)
|
||||||
|
@ -618,16 +648,40 @@ insertAll ebs = do
|
||||||
getCommit (BudgetCommit c _) = c
|
getCommit (BudgetCommit c _) = c
|
||||||
|
|
||||||
insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m ()
|
insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m ()
|
||||||
insertTx c InsertTx {itxDate, itxDescr, itxEntries, itxCommit} = do
|
insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxCommit} = do
|
||||||
let anyDeferred = any (isJust . feDeferred) itxEntries
|
k <- insert $ TransactionR c itxDate itxDescr
|
||||||
k <- insert $ TransactionR c itxDate itxDescr anyDeferred
|
mapM_ (uncurry (insertEntrySet k)) $ zip [0 ..] (NE.toList itxEntrySets)
|
||||||
mapM_ (go k) itxEntries
|
|
||||||
where
|
where
|
||||||
go k tx = do
|
insertEntrySet tk i InsertEntrySet {iesCurrency, iesFromEntries, iesToEntries} = do
|
||||||
ek <- insertEntry k tx
|
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
|
case itxCommit of
|
||||||
BudgetCommit _ name -> insert_ $ BudgetLabelR ek name
|
BudgetCommit _ name -> insert_ $ BudgetLabelR ek name
|
||||||
_ -> return ()
|
_ -> 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 :: MonadSqlQuery m => UEBalanced -> m ()
|
||||||
updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. unStaticValue ueValue]
|
updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. unStaticValue ueValue]
|
||||||
|
|
|
@ -44,11 +44,15 @@ TransactionR sql=transactions
|
||||||
commit CommitRId OnDeleteCascade
|
commit CommitRId OnDeleteCascade
|
||||||
date Day
|
date Day
|
||||||
description T.Text
|
description T.Text
|
||||||
deferred Bool
|
|
||||||
deriving Show Eq
|
deriving Show Eq
|
||||||
EntryR sql=entries
|
EntrySetR sql=entry_sets
|
||||||
transaction TransactionRId OnDeleteCascade
|
transaction TransactionRId OnDeleteCascade
|
||||||
currency CurrencyRId OnDeleteCascade
|
currency CurrencyRId OnDeleteCascade
|
||||||
|
index Int
|
||||||
|
rebalance Bool
|
||||||
|
deriving Show Eq
|
||||||
|
EntryR sql=entries
|
||||||
|
entryset EntrySetRId OnDeleteCascade
|
||||||
account AccountRId OnDeleteCascade
|
account AccountRId OnDeleteCascade
|
||||||
memo T.Text
|
memo T.Text
|
||||||
value Rational
|
value Rational
|
||||||
|
|
|
@ -459,7 +459,7 @@ data Statement = Statement
|
||||||
, stmtTxOpts :: !(TxOpts T.Text)
|
, stmtTxOpts :: !(TxOpts T.Text)
|
||||||
, stmtSkipLines :: !Natural
|
, stmtSkipLines :: !Natural
|
||||||
}
|
}
|
||||||
deriving (Eq, Hashable, Generic, FromDhall)
|
deriving (Eq, Hashable, Generic, FromDhall, Show)
|
||||||
|
|
||||||
-- | the value of a field in entry (text version)
|
-- | the value of a field in entry (text version)
|
||||||
-- can either be a raw (constant) value, a lookup from the record, or a map
|
-- can either be a raw (constant) value, a lookup from the record, or a map
|
||||||
|
|
|
@ -37,6 +37,7 @@ data ConfigHashes = ConfigHashes
|
||||||
type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
|
type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
|
||||||
|
|
||||||
data CurrencyPrec = CurrencyPrec {cpID :: !CurrencyRId, cpPrec :: !Natural}
|
data CurrencyPrec = CurrencyPrec {cpID :: !CurrencyRId, cpPrec :: !Natural}
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
type CurrencyMap = M.Map CurID CurrencyPrec
|
type CurrencyMap = M.Map CurID CurrencyPrec
|
||||||
|
|
||||||
|
@ -50,6 +51,7 @@ data DBState = DBState
|
||||||
, kmStatementInterval :: !DaySpan
|
, kmStatementInterval :: !DaySpan
|
||||||
, kmNewCommits :: ![Int]
|
, kmNewCommits :: ![Int]
|
||||||
}
|
}
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
data DBUpdates = DBUpdates
|
data DBUpdates = DBUpdates
|
||||||
{ duOldCommits :: ![Int]
|
{ duOldCommits :: ![Int]
|
||||||
|
@ -79,7 +81,7 @@ data UpdateEntry i v = UpdateEntry
|
||||||
{ ueID :: !i
|
{ ueID :: !i
|
||||||
, ueAcnt :: !AccountRId
|
, ueAcnt :: !AccountRId
|
||||||
, ueValue :: !v
|
, ueValue :: !v
|
||||||
, ueIndex :: !Int -- TODO this isn't needed for primary entries
|
, ueIndex :: !Int
|
||||||
}
|
}
|
||||||
|
|
||||||
data CurrencyRound = CurrencyRound CurID Natural
|
data CurrencyRound = CurrencyRound CurID Natural
|
||||||
|
@ -107,32 +109,27 @@ type UE_RO = UpdateEntry () StaticValue
|
||||||
|
|
||||||
type UEBalanced = UpdateEntry EntryRId StaticValue
|
type UEBalanced = UpdateEntry EntryRId StaticValue
|
||||||
|
|
||||||
data UpdateEntrySet = UpdateEntrySet
|
data UpdateEntrySet f t = UpdateEntrySet
|
||||||
{ utFrom0 :: !UEBlank
|
{ utFrom0 :: !f
|
||||||
, utTo0 :: !UEBlank
|
, utTo0 :: !UEBlank
|
||||||
, utPairs :: ![(UEUnk, [UELink])]
|
, utFromUnk :: ![(UEUnk, [UELink])]
|
||||||
, utFromUnk :: ![UEUnk]
|
|
||||||
, utToUnk :: ![UEUnk]
|
, utToUnk :: ![UEUnk]
|
||||||
, utToUnkLink0 :: ![UELink]
|
|
||||||
, utFromRO :: ![UE_RO]
|
, utFromRO :: ![UE_RO]
|
||||||
, utToRO :: ![UE_RO]
|
, utToRO :: ![UE_RO]
|
||||||
, utCurrency :: !CurrencyRId
|
, utCurrency :: !CurrencyRId
|
||||||
, utDate :: !Day
|
, utDate :: !Day
|
||||||
, utTotalValue :: !Rational
|
, utTotalValue :: !t
|
||||||
}
|
}
|
||||||
|
|
||||||
|
type TotalUpdateEntrySet = UpdateEntrySet (UEBlank, [UELink]) Rational
|
||||||
|
|
||||||
|
type FullUpdateEntrySet = UpdateEntrySet (Either UE_RO (UEUnk, [UELink])) ()
|
||||||
|
|
||||||
data EntryBin
|
data EntryBin
|
||||||
= ToUpdate UpdateEntrySet
|
= ToUpdate (Either TotalUpdateEntrySet FullUpdateEntrySet)
|
||||||
| ToRead ReadEntry
|
| ToRead ReadEntry
|
||||||
| ToInsert (Tx TxCommit)
|
| 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 KeyEntry = InsertEntry AccountRId CurrencyRId TagRId
|
||||||
|
|
||||||
type BalEntry = InsertEntry AcntID CurID TagID
|
type BalEntry = InsertEntry AcntID CurID TagID
|
||||||
|
@ -206,49 +203,75 @@ accountSign IncomeT = Credit
|
||||||
accountSign LiabilityT = Credit
|
accountSign LiabilityT = Credit
|
||||||
accountSign EquityT = Credit
|
accountSign EquityT = Credit
|
||||||
|
|
||||||
data HalfEntrySet a c t v = HalfEntrySet
|
data HalfEntrySet v0 vN = HalfEntrySet
|
||||||
{ hesPrimary :: !(Entry a () t)
|
{ hesPrimary :: !(Entry AcntID v0 TagID)
|
||||||
, hesOther :: ![Entry a v t]
|
, hesOther :: ![Entry AcntID vN TagID]
|
||||||
}
|
}
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
data EntrySet a c t v v' = EntrySet
|
data EntrySet v0 vp0 vpN vtN = EntrySet
|
||||||
{ esTotalValue :: !v'
|
{ esTotalValue :: !v0
|
||||||
, esCurrency :: !c
|
, esCurrency :: !CurrencyPrec
|
||||||
, esFrom :: !(HalfEntrySet a c t (EntryValue v))
|
, esFrom :: !(HalfEntrySet vp0 vpN)
|
||||||
, esTo :: !(HalfEntrySet a c t (LinkDeferred v))
|
, 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
|
data Tx k = Tx
|
||||||
{ txDescr :: !T.Text
|
{ txDescr :: !T.Text
|
||||||
, txDate :: !Day
|
, txDate :: !Day
|
||||||
, txPrimary :: !(EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational))
|
, txPrimary :: !(Either PrimaryEntrySet TransferEntrySet)
|
||||||
, txOther :: ![EntrySet AcntID CurrencyPrec TagID Rational (Either Double (EntryValue Rational))]
|
, txOther :: ![Either SecondayEntrySet ShadowEntrySet]
|
||||||
, txCommit :: !k
|
, 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
|
data InsertTx = InsertTx
|
||||||
{ itxDescr :: !T.Text
|
{ itxDescr :: !T.Text
|
||||||
, itxDate :: !Day
|
, itxDate :: !Day
|
||||||
, itxEntries :: ![InsertEntry AccountRId CurrencyRId TagRId]
|
, itxEntrySets :: !(NonEmpty InsertEntrySet)
|
||||||
, itxCommit :: !TxCommit
|
, itxCommit :: !TxCommit
|
||||||
}
|
}
|
||||||
deriving (Generic)
|
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
|
data Deferred a = Deferred Bool a
|
||||||
deriving (Show, Functor, Foldable, Traversable)
|
deriving (Show, Functor, Foldable, Traversable)
|
||||||
|
|
||||||
|
|
|
@ -64,7 +64,6 @@ module Internal.Utils
|
||||||
, expandTransfers
|
, expandTransfers
|
||||||
, expandTransfer
|
, expandTransfer
|
||||||
, entryPair
|
, entryPair
|
||||||
, entryPair_
|
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -334,20 +333,21 @@ toTx
|
||||||
, txDescr = trDesc
|
, txDescr = trDesc
|
||||||
, txCommit = ()
|
, txCommit = ()
|
||||||
, txPrimary =
|
, txPrimary =
|
||||||
EntrySet
|
Left $
|
||||||
{ esTotalValue = EntryValue TFixed $ roundPrecisionCur cur $ tgScale * fromRational trAmount
|
EntrySet
|
||||||
, esCurrency = cur
|
{ esTotalValue = roundPrecisionCur cur $ tgScale * fromRational trAmount
|
||||||
, esFrom = f
|
, esCurrency = cur
|
||||||
, esTo = t
|
, esFrom = f
|
||||||
}
|
, esTo = t
|
||||||
, txOther = ss
|
}
|
||||||
|
, txOther = fmap Left ss
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
curRes = do
|
curRes = do
|
||||||
m <- askDBState kmCurrency
|
m <- askDBState kmCurrency
|
||||||
cur <- liftInner $ resolveCurrency m r tgCurrency
|
cur <- liftInner $ resolveCurrency m r tgCurrency
|
||||||
let fromRes = liftInner $ resolveHalfEntry resolveFromValue cur r tgFrom
|
let fromRes = liftInner $ resolveHalfEntry resolveFromValue cur r () tgFrom
|
||||||
let toRes = liftInner $ resolveHalfEntry resolveToValue cur r tgTo
|
let toRes = liftInner $ resolveHalfEntry resolveToValue cur r () tgTo
|
||||||
combineError fromRes toRes (cur,,)
|
combineError fromRes toRes (cur,,)
|
||||||
subRes = mapErrors (resolveSubGetter r) tgOtherEntries
|
subRes = mapErrors (resolveSubGetter r) tgOtherEntries
|
||||||
|
|
||||||
|
@ -355,35 +355,37 @@ resolveSubGetter
|
||||||
:: MonadFinance m
|
:: MonadFinance m
|
||||||
=> TxRecord
|
=> TxRecord
|
||||||
-> TxSubGetter
|
-> TxSubGetter
|
||||||
-> InsertExceptT m (EntrySet AcntID CurrencyPrec TagID Rational (Either Double (EntryValue Rational)))
|
-> InsertExceptT m SecondayEntrySet
|
||||||
resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
|
resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
|
||||||
m <- askDBState kmCurrency
|
m <- askDBState kmCurrency
|
||||||
cur <- liftInner $ resolveCurrency m r tsgCurrency
|
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
|
let valRes = liftInner $ fmap (roundPrecisionCur cur) <$> resolveValue r tsgValue
|
||||||
liftInner $ combineError3 fromRes toRes valRes $ \f t v ->
|
liftInner $ combineErrorM toRes valRes $ \t v -> do
|
||||||
EntrySet
|
f <- resolveHalfEntry resolveFromValue cur r v tsgFrom
|
||||||
{ esTotalValue = Right v
|
return $
|
||||||
, esCurrency = cur
|
EntrySet
|
||||||
, esFrom = f
|
{ esTotalValue = ()
|
||||||
, esTo = t
|
, esCurrency = cur
|
||||||
}
|
, esFrom = f
|
||||||
|
, esTo = t
|
||||||
|
}
|
||||||
|
|
||||||
resolveHalfEntry
|
resolveHalfEntry
|
||||||
:: Traversable f
|
:: Traversable f
|
||||||
=> (TxRecord -> n -> InsertExcept (f Double))
|
=> (TxRecord -> n -> InsertExcept (f Double))
|
||||||
-> CurrencyPrec
|
-> CurrencyPrec
|
||||||
-> TxRecord
|
-> TxRecord
|
||||||
|
-> v
|
||||||
-> TxHalfGetter (EntryGetter n)
|
-> TxHalfGetter (EntryGetter n)
|
||||||
-> InsertExcept (HalfEntrySet AcntID CurrencyPrec TagID (f Rational))
|
-> InsertExcept (HalfEntrySet v (f Rational))
|
||||||
resolveHalfEntry f cur r TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} =
|
resolveHalfEntry f cur r v TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} =
|
||||||
combineError acntRes esRes $ \a es ->
|
combineError acntRes esRes $ \a es ->
|
||||||
HalfEntrySet
|
HalfEntrySet
|
||||||
{ hesPrimary =
|
{ hesPrimary =
|
||||||
Entry
|
Entry
|
||||||
{ eAcnt = a
|
{ eAcnt = a
|
||||||
, eValue = ()
|
, eValue = v
|
||||||
, eComment = thgComment
|
, eComment = thgComment
|
||||||
, eTags = thgTags
|
, eTags = thgTags
|
||||||
}
|
}
|
||||||
|
@ -913,10 +915,10 @@ unlessLefts_ e f = unlessLefts e (\x -> void (f x) >> return mzero)
|
||||||
-- where
|
-- where
|
||||||
-- go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
|
-- 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)
|
groupKey f = fmap go . NE.groupAllWith (f . fst)
|
||||||
where
|
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 :: Ord b => (a -> b) -> [a] -> [(b, [a])]
|
||||||
groupWith f = fmap go . NE.groupAllWith fst . fmap (\x -> (f x, x))
|
groupWith f = fmap go . NE.groupAllWith fst . fmap (\x -> (f x, x))
|
||||||
|
@ -1037,56 +1039,54 @@ balanceTxs ebs =
|
||||||
first concat . partitionEithers . catMaybes
|
first concat . partitionEithers . catMaybes
|
||||||
<$> evalStateT (mapErrors go $ L.sortOn binDate ebs) M.empty
|
<$> evalStateT (mapErrors go $ L.sortOn binDate ebs) M.empty
|
||||||
where
|
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
|
go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do
|
||||||
modify $ mapAdd_ (reAcnt, reCurrency) reValue
|
modify $ mapAdd_ (reAcnt, reCurrency) reValue
|
||||||
return Nothing
|
return Nothing
|
||||||
go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate}) = do
|
go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate}) = do
|
||||||
e <- balanceEntrySet primaryBalance txPrimary
|
e <- either balancePrimaryEntrySet balanceSecondaryEntrySet txPrimary
|
||||||
-- TODO this logic is really stupid, I'm balancing the total twice; fix
|
let tot = sum $ fmap (eValue . ieEntry) $ NE.toList $ iesFromEntries e
|
||||||
-- will likely entail making a separate data structure for txs derived
|
es <- mapErrors (either balanceSecondaryEntrySet (balancePrimaryEntrySet . fromShadow tot)) txOther
|
||||||
-- from transfers vs statements
|
|
||||||
let etot = sum $ eValue . feEntry <$> filter ((< 0) . feIndex) e
|
|
||||||
es <- mapErrors (balanceEntrySet (secondaryBalance etot)) txOther
|
|
||||||
let tx =
|
let tx =
|
||||||
InsertTx
|
InsertTx
|
||||||
{ itxDescr = txDescr
|
{ itxDescr = txDescr
|
||||||
, itxDate = txDate
|
, itxDate = txDate
|
||||||
, itxEntries = concat $ e : es
|
, itxEntrySets = e :| es
|
||||||
, itxCommit = txCommit
|
, itxCommit = txCommit
|
||||||
}
|
}
|
||||||
return $ Just $ Right tx
|
return $ Just $ Right tx
|
||||||
primaryBalance Entry {eAcnt} c (EntryValue t v) = findBalance eAcnt c t v
|
fromShadow tot e@EntrySet {esTotalValue} = e {esTotalValue = tot * toRational esTotalValue}
|
||||||
secondaryBalance tot Entry {eAcnt} c val = case val of
|
|
||||||
Right (EntryValue t v) -> findBalance eAcnt c t v
|
|
||||||
Left v -> return $ toRational v * tot
|
|
||||||
|
|
||||||
binDate :: EntryBin -> Day
|
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 (ToRead ReadEntry {reDate}) = reDate
|
||||||
binDate (ToInsert Tx {txDate}) = txDate
|
binDate (ToInsert Tx {txDate}) = txDate
|
||||||
|
|
||||||
type EntryBals = M.Map (AccountRId, CurrencyRId) Rational
|
type EntryBals = M.Map (AccountRId, CurrencyRId) Rational
|
||||||
|
|
||||||
data UpdateEntryType a
|
data UpdateEntryType a b
|
||||||
= UET_ReadOnly UE_RO
|
= UET_ReadOnly UE_RO
|
||||||
| UET_Unk UEUnk
|
| UET_Unk a
|
||||||
| UET_Linked a
|
| UET_Linked b
|
||||||
|
|
||||||
-- TODO make sure new values are rounded properly here
|
-- TODO make sure new values are rounded properly here
|
||||||
rebalanceEntrySet :: UpdateEntrySet -> State EntryBals [UEBalanced]
|
rebalanceTotalEntrySet :: TotalUpdateEntrySet -> State EntryBals [UEBalanced]
|
||||||
rebalanceEntrySet
|
rebalanceTotalEntrySet
|
||||||
UpdateEntrySet
|
UpdateEntrySet
|
||||||
{ utFrom0
|
{ utFrom0 = (f0, f0links)
|
||||||
, utTo0
|
, utTo0
|
||||||
, utPairs
|
, -- , utPairs
|
||||||
, utFromUnk
|
utFromUnk
|
||||||
, utToUnk
|
, utToUnk
|
||||||
, utFromRO
|
, utFromRO
|
||||||
, utToRO
|
, utToRO
|
||||||
, utCurrency
|
, utCurrency
|
||||||
, utToUnkLink0
|
, -- , utToUnkLink0
|
||||||
, utTotalValue
|
utTotalValue
|
||||||
} =
|
} =
|
||||||
do
|
do
|
||||||
(f0val, (tpairs, fs)) <-
|
(f0val, (tpairs, fs)) <-
|
||||||
|
@ -1094,10 +1094,9 @@ rebalanceEntrySet
|
||||||
foldM goFrom (utTotalValue, []) $
|
foldM goFrom (utTotalValue, []) $
|
||||||
L.sortOn idx $
|
L.sortOn idx $
|
||||||
(UET_ReadOnly <$> utFromRO)
|
(UET_ReadOnly <$> utFromRO)
|
||||||
++ (UET_Unk <$> utFromUnk)
|
++ (UET_Linked <$> utFromUnk)
|
||||||
++ (UET_Linked <$> utPairs)
|
let f0' = f0 {ueValue = StaticValue f0val}
|
||||||
let f0 = utFrom0 {ueValue = StaticValue f0val}
|
let tsLink0 = fmap (unlink (-f0val)) f0links
|
||||||
let tsLink0 = fmap (unlink (-f0val)) utToUnkLink0
|
|
||||||
(t0val, tsUnk) <-
|
(t0val, tsUnk) <-
|
||||||
fmap (second catMaybes) $
|
fmap (second catMaybes) $
|
||||||
foldM goTo (-utTotalValue, []) $
|
foldM goTo (-utTotalValue, []) $
|
||||||
|
@ -1106,7 +1105,7 @@ rebalanceEntrySet
|
||||||
++ (UET_Unk <$> utToUnk)
|
++ (UET_Unk <$> utToUnk)
|
||||||
++ (UET_ReadOnly <$> utToRO)
|
++ (UET_ReadOnly <$> utToRO)
|
||||||
let t0 = utTo0 {ueValue = StaticValue t0val}
|
let t0 = utTo0 {ueValue = StaticValue t0val}
|
||||||
return (f0 : fs ++ (t0 : tsUnk))
|
return (f0' : fs ++ (t0 : tsUnk))
|
||||||
where
|
where
|
||||||
project f _ _ (UET_ReadOnly e) = f e
|
project f _ _ (UET_ReadOnly e) = f e
|
||||||
project _ f _ (UET_Unk e) = f e
|
project _ f _ (UET_Unk e) = f e
|
||||||
|
@ -1149,13 +1148,126 @@ rebalanceEntrySet
|
||||||
return v
|
return v
|
||||||
unlink v e = e {ueValue = StaticValue $ v * unLinkScale (ueValue e)}
|
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)
|
:: (MonadInsertError m, MonadFinance m)
|
||||||
=> (Entry AccountRId AcntSign TagRId -> CurrencyRId -> v -> State EntryBals Rational)
|
=> SecondayEntrySet
|
||||||
-> DeferredEntrySet v
|
-> StateT EntryBals m InsertEntrySet
|
||||||
-> StateT EntryBals m [KeyEntry]
|
balanceSecondaryEntrySet
|
||||||
balanceEntrySet
|
EntrySet
|
||||||
findTot
|
{ 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
|
EntrySet
|
||||||
{ esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
|
{ esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
|
||||||
, esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
|
, esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
|
||||||
|
@ -1163,53 +1275,48 @@ balanceEntrySet
|
||||||
, esTotalValue
|
, esTotalValue
|
||||||
} =
|
} =
|
||||||
do
|
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 f0res = resolveAcntAndTags f0
|
||||||
let t0res = resolveAcntAndTags t0
|
let t0res = resolveAcntAndTags t0
|
||||||
combineErrorM f0res t0res $ \f0' t0' -> do
|
let fsres = mapErrors resolveAcntAndTags fs
|
||||||
-- 2. Compute total value of transaction using the primary debit entry
|
let tsres = mapErrors resolveAcntAndTags ts
|
||||||
tot <- liftInnerS $ findTot f0' curID esTotalValue
|
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 esTotalValue f0' fs'
|
||||||
|
|
||||||
-- 3. Balance all debit entries (including primary). Note the negative
|
let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs''
|
||||||
-- indices, which will signify them to be debit entries when updated
|
|
||||||
-- later.
|
|
||||||
let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a) curID
|
|
||||||
fs' <- doEntries balFromEntry curID tot f0' fs (NE.iterate (+ (-1)) (-1))
|
|
||||||
|
|
||||||
-- 4. Build an array of debit values be linked as desired in credit entries
|
let balToEntry = balanceEntry (balanceLinked fv curID precision) curID
|
||||||
let fv = V.fromList $ fmap (eValue . feEntry) fs'
|
ts'' <- doEntries balToEntry curID (-esTotalValue) t0' ts'
|
||||||
|
return $
|
||||||
-- 4. Balance credit entries (including primary) analogously.
|
InsertEntrySet
|
||||||
let balToEntry = balanceEntry (balanceLinked fv curID precision) curID
|
{ iesCurrency = curID
|
||||||
ts' <- doEntries balToEntry curID (-tot) t0' ts (NE.iterate (+ 1) 0)
|
, iesFromEntries = fs''
|
||||||
return $ fs' ++ ts'
|
, iesToEntries = ts''
|
||||||
|
}
|
||||||
|
|
||||||
doEntries
|
doEntries
|
||||||
:: (MonadInsertError m)
|
:: (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
|
-> CurrencyRId
|
||||||
-> Rational
|
-> Rational
|
||||||
-> Entry AccountRId AcntSign TagRId
|
-> Entry (AccountRId, AcntSign) () TagRId
|
||||||
-> [Entry AcntID v TagID]
|
-> [Entry (AccountRId, AcntSign) v TagRId]
|
||||||
-> NonEmpty Int
|
-> StateT EntryBals m (NonEmpty (InsertEntry AccountRId CurrencyRId TagRId))
|
||||||
-> StateT EntryBals m [InsertEntry AccountRId CurrencyRId TagRId]
|
doEntries f curID tot e@Entry {eAcnt = (acntID, sign)} es = do
|
||||||
doEntries f curID tot e es (i0 :| iN) = do
|
es' <- mapErrors f es
|
||||||
es' <- mapErrors (uncurry f) $ zip iN es
|
|
||||||
let e0val = tot - entrySum es'
|
let e0val = tot - entrySum es'
|
||||||
-- TODO not dry
|
-- TODO not dry
|
||||||
let s = fromIntegral $ sign2Int (eValue e) -- NOTE hack
|
let s = fromIntegral $ sign2Int sign -- NOTE hack
|
||||||
modify (mapAdd_ (eAcnt e, curID) tot)
|
modify (mapAdd_ (acntID, curID) e0val)
|
||||||
let e' =
|
let e' =
|
||||||
InsertEntry
|
InsertEntry
|
||||||
{ feEntry = e {eValue = s * e0val}
|
{ ieEntry = e {eValue = s * e0val, eAcnt = acntID}
|
||||||
, feCurrency = curID
|
, ieDeferred = Nothing
|
||||||
, feDeferred = Nothing
|
|
||||||
, feIndex = i0
|
|
||||||
}
|
}
|
||||||
return $ e' : es'
|
return $ e' :| es'
|
||||||
where
|
where
|
||||||
entrySum = sum . fmap (eValue . feEntry)
|
entrySum = sum . fmap (eValue . ieEntry)
|
||||||
|
|
||||||
liftInnerS :: Monad m => StateT e Identity a -> StateT e m a
|
liftInnerS :: Monad m => StateT e Identity a -> StateT e m a
|
||||||
liftInnerS = mapStateT (return . runIdentity)
|
liftInnerS = mapStateT (return . runIdentity)
|
||||||
|
@ -1248,38 +1355,30 @@ balanceDeferred curID acntID (EntryValue t v) = do
|
||||||
return (newval, d)
|
return (newval, d)
|
||||||
|
|
||||||
balanceEntry
|
balanceEntry
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
:: (MonadInsertError m)
|
||||||
=> (AccountRId -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
|
=> (AccountRId -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
|
||||||
-> CurrencyRId
|
-> CurrencyRId
|
||||||
-> Int
|
-> Entry (AccountRId, AcntSign) v TagRId
|
||||||
-> Entry AcntID v TagID
|
|
||||||
-> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId)
|
-> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId)
|
||||||
balanceEntry f curID idx e@Entry {eValue, eAcnt, eTags} = do
|
balanceEntry f curID e@Entry {eValue, eAcnt = (acntID, sign)} = do
|
||||||
let acntRes = lookupAccount eAcnt
|
let s = fromIntegral $ sign2Int sign
|
||||||
let tagRes = mapErrors lookupTag eTags
|
(newVal, deferred) <- f acntID eValue
|
||||||
combineErrorM acntRes tagRes $ \(acntID, sign, _) tags -> do
|
modify (mapAdd_ (acntID, curID) newVal)
|
||||||
let s = fromIntegral $ sign2Int sign
|
return $
|
||||||
(newVal, deferred) <- f acntID eValue
|
InsertEntry
|
||||||
modify (mapAdd_ (acntID, curID) newVal)
|
{ ieEntry = e {eValue = s * newVal, eAcnt = acntID}
|
||||||
return $
|
, ieDeferred = deferred
|
||||||
InsertEntry
|
}
|
||||||
{ feEntry = e {eValue = s * newVal, eAcnt = acntID, eTags = tags}
|
|
||||||
, feCurrency = curID
|
|
||||||
, feDeferred = deferred
|
|
||||||
, feIndex = idx
|
|
||||||
}
|
|
||||||
|
|
||||||
resolveAcntAndTags
|
resolveAcntAndTags
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
:: (MonadInsertError m, MonadFinance m)
|
||||||
=> Entry AcntID v TagID
|
=> Entry AcntID v TagID
|
||||||
-> m (Entry AccountRId AcntSign TagRId)
|
-> m (Entry (AccountRId, AcntSign) v TagRId)
|
||||||
resolveAcntAndTags e@Entry {eAcnt, eTags} = do
|
resolveAcntAndTags e@Entry {eAcnt, eTags} = do
|
||||||
let acntRes = lookupAccount eAcnt
|
let acntRes = lookupAccount eAcnt
|
||||||
let tagRes = mapErrors lookupTag eTags
|
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 $
|
combineError acntRes tagRes $
|
||||||
\(acntID, sign, _) tags -> e {eAcnt = acntID, eTags = tags, eValue = sign}
|
\(acntID, sign, _) tags -> e {eAcnt = (acntID, sign), eTags = tags}
|
||||||
|
|
||||||
findBalance
|
findBalance
|
||||||
:: AccountRId
|
:: AccountRId
|
||||||
|
@ -1310,7 +1409,7 @@ expandTransfer
|
||||||
-> m [Tx TxCommit]
|
-> m [Tx TxCommit]
|
||||||
expandTransfer tc bounds Transfer {transAmounts, transTo, transCurrency, transFrom} = do
|
expandTransfer tc bounds Transfer {transAmounts, transTo, transCurrency, transFrom} = do
|
||||||
txs <- mapErrors go transAmounts
|
txs <- mapErrors go transAmounts
|
||||||
return $ filter (inDaySpan bounds . txDate) $ concat txs
|
return $ concat txs
|
||||||
where
|
where
|
||||||
go
|
go
|
||||||
Amount
|
Amount
|
||||||
|
@ -1318,13 +1417,13 @@ expandTransfer tc bounds Transfer {transAmounts, transTo, transCurrency, transFr
|
||||||
, amtValue = TransferValue {tvVal = v, tvType = t}
|
, amtValue = TransferValue {tvVal = v, tvType = t}
|
||||||
, amtDesc = desc
|
, amtDesc = desc
|
||||||
} =
|
} =
|
||||||
withDates pat $ \day -> do
|
withDates bounds pat $ \day -> do
|
||||||
p <- entryPair_ (\_ x -> EntryValue t $ toRational x) transFrom transTo transCurrency desc v
|
p <- entryPair transFrom transTo transCurrency desc () (EntryValue t (toRational (-v)))
|
||||||
return
|
return
|
||||||
Tx
|
Tx
|
||||||
{ txCommit = tc
|
{ txCommit = tc
|
||||||
, txDate = day
|
, txDate = day
|
||||||
, txPrimary = p
|
, txPrimary = Right p
|
||||||
, txOther = []
|
, txOther = []
|
||||||
, txDescr = desc
|
, txDescr = desc
|
||||||
}
|
}
|
||||||
|
@ -1335,43 +1434,32 @@ entryPair
|
||||||
-> TaggedAcnt
|
-> TaggedAcnt
|
||||||
-> CurID
|
-> CurID
|
||||||
-> T.Text
|
-> T.Text
|
||||||
-> Double
|
-> v0
|
||||||
-> m (EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational))
|
-> v1
|
||||||
entryPair = entryPair_ (fmap (EntryValue TFixed) . roundPrecisionCur)
|
-> m (EntrySet v0 v1 v2 v3)
|
||||||
|
entryPair (TaggedAcnt fa fts) (TaggedAcnt ta tts) curid com totval val1 = do
|
||||||
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
|
|
||||||
cp <- lookupCurrency curid
|
cp <- lookupCurrency curid
|
||||||
return $ pair cp from to_ (f cp val)
|
return $
|
||||||
|
EntrySet
|
||||||
|
{ esCurrency = cp
|
||||||
|
, esTotalValue = totval
|
||||||
|
, esFrom = halfEntry fa fts val1
|
||||||
|
, esTo = halfEntry ta tts ()
|
||||||
|
}
|
||||||
where
|
where
|
||||||
halfEntry :: a -> [t] -> HalfEntrySet a c t v
|
halfEntry :: AcntID -> [TagID] -> v -> HalfEntrySet v v0
|
||||||
halfEntry a ts =
|
halfEntry a ts v =
|
||||||
HalfEntrySet
|
HalfEntrySet
|
||||||
{ hesPrimary = Entry {eAcnt = a, eValue = (), eComment = com, eTags = ts}
|
{ hesPrimary = Entry {eAcnt = a, eValue = v, eComment = com, eTags = ts}
|
||||||
, hesOther = []
|
, hesOther = []
|
||||||
}
|
}
|
||||||
pair cp (TaggedAcnt fa fts) (TaggedAcnt ta tts) v =
|
|
||||||
EntrySet
|
|
||||||
{ esCurrency = cp
|
|
||||||
, esTotalValue = v
|
|
||||||
, esFrom = halfEntry fa fts
|
|
||||||
, esTo = halfEntry ta tts
|
|
||||||
}
|
|
||||||
|
|
||||||
withDates
|
withDates
|
||||||
:: (MonadFinance m, MonadInsertError m)
|
:: (MonadFinance m, MonadInsertError m)
|
||||||
=> DatePat
|
=> DaySpan
|
||||||
|
-> DatePat
|
||||||
-> (Day -> m a)
|
-> (Day -> m a)
|
||||||
-> m [a]
|
-> m [a]
|
||||||
withDates dp f = do
|
withDates bounds dp f = do
|
||||||
bounds <- askDBState kmBudgetInterval
|
|
||||||
days <- liftExcept $ expandDatePat bounds dp
|
days <- liftExcept $ expandDatePat bounds dp
|
||||||
combineErrors $ fmap f days
|
combineErrors $ fmap f days
|
||||||
|
|
Loading…
Reference in New Issue