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
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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,174 +422,206 @@ 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
|
||||
, txs ^. TransactionRDate
|
||||
, entries
|
||||
( 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
|
||||
let tot = sum $ fmap (entryRValue . snd) froms
|
||||
(from0, fromRO, fromUnk, fromVec) <- splitFrom $ reverse froms
|
||||
(to0, toRO, toUnk, toLink0, toLinkN) <- splitTo fromVec tos
|
||||
return
|
||||
UpdateEntrySet
|
||||
{ utDate = day
|
||||
, utCurrency = cur
|
||||
, utFrom0 = from0
|
||||
, 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
|
||||
, reAcnt = entryRAccount e
|
||||
, reValue = entryRValue e
|
||||
}
|
||||
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, 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 = E.unValue day
|
||||
, utCurrency = E.unValue curID
|
||||
, utFrom0 = x
|
||||
, utTo0 = to0
|
||||
, utFromRO = fromRO
|
||||
, utToRO = toRO
|
||||
, utFromUnk = fromUnk
|
||||
, utToUnk = toUnk
|
||||
, utTotalValue = tot
|
||||
}
|
||||
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
|
||||
makeLinkUnk (k, e) =
|
||||
maybe
|
||||
(throwError $ InsertException undefined)
|
||||
(return . makeUE k e . LinkScale)
|
||||
$ entryRCachedValue e
|
||||
|
||||
-- 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)
|
||||
(return . makeUE k e . LinkScale)
|
||||
$ 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]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -64,7 +64,6 @@ module Internal.Utils
|
|||
, expandTransfers
|
||||
, expandTransfer
|
||||
, entryPair
|
||||
, entryPair_
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -334,20 +333,21 @@ toTx
|
|||
, txDescr = trDesc
|
||||
, txCommit = ()
|
||||
, txPrimary =
|
||||
EntrySet
|
||||
{ esTotalValue = EntryValue TFixed $ roundPrecisionCur cur $ tgScale * fromRational trAmount
|
||||
, esCurrency = cur
|
||||
, esFrom = f
|
||||
, esTo = t
|
||||
}
|
||||
, txOther = ss
|
||||
Left $
|
||||
EntrySet
|
||||
{ esTotalValue = roundPrecisionCur cur $ tgScale * fromRational trAmount
|
||||
, esCurrency = cur
|
||||
, esFrom = f
|
||||
, esTo = t
|
||||
}
|
||||
, 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,35 +355,37 @@ 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 ->
|
||||
EntrySet
|
||||
{ esTotalValue = Right v
|
||||
, esCurrency = cur
|
||||
, esFrom = f
|
||||
, esTo = t
|
||||
}
|
||||
liftInner $ combineErrorM toRes valRes $ \t v -> do
|
||||
f <- resolveHalfEntry resolveFromValue cur r v tsgFrom
|
||||
return $
|
||||
EntrySet
|
||||
{ esTotalValue = ()
|
||||
, esCurrency = cur
|
||||
, esFrom = f
|
||||
, esTo = t
|
||||
}
|
||||
|
||||
resolveHalfEntry
|
||||
:: Traversable f
|
||||
=> (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
|
||||
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 esTotalValue f0' fs'
|
||||
|
||||
-- 3. Balance all debit entries (including primary). Note the negative
|
||||
-- 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))
|
||||
let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs''
|
||||
|
||||
-- 4. Build an array of debit values be linked as desired in credit entries
|
||||
let fv = V.fromList $ fmap (eValue . feEntry) 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'
|
||||
let balToEntry = balanceEntry (balanceLinked fv curID precision) curID
|
||||
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
|
||||
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
|
||||
}
|
||||
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
|
||||
{ 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)
|
||||
return $
|
||||
EntrySet
|
||||
{ esCurrency = cp
|
||||
, esTotalValue = totval
|
||||
, esFrom = halfEntry fa fts val1
|
||||
, esTo = halfEntry ta tts ()
|
||||
}
|
||||
where
|
||||
halfEntry :: a -> [t] -> HalfEntrySet a c t v
|
||||
halfEntry a ts =
|
||||
halfEntry :: AcntID -> [TagID] -> v -> HalfEntrySet v v0
|
||||
halfEntry a ts v =
|
||||
HalfEntrySet
|
||||
{ hesPrimary = Entry {eAcnt = a, eValue = (), eComment = com, eTags = ts}
|
||||
{ hesPrimary = Entry {eAcnt = a, eValue = v, eComment = com, eTags = ts}
|
||||
, hesOther = []
|
||||
}
|
||||
pair cp (TaggedAcnt fa fts) (TaggedAcnt ta tts) v =
|
||||
EntrySet
|
||||
{ esCurrency = cp
|
||||
, esTotalValue = v
|
||||
, esFrom = halfEntry fa fts
|
||||
, esTo = halfEntry ta tts
|
||||
}
|
||||
|
||||
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
|
||||
|
|
|
|||
Loading…
Reference in New Issue