From bae847d9f3aa6258bd0c94abcb170c745a25c1b5 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Mon, 3 Jul 2023 20:27:52 -0400 Subject: [PATCH] WIP balance transactions in two different ways --- app/Main.hs | 4 +- lib/Internal/Budget.hs | 32 +-- lib/Internal/Database.hs | 338 ++++++++++++++++------------- lib/Internal/Types/Database.hs | 8 +- lib/Internal/Types/Dhall.hs | 2 +- lib/Internal/Types/Main.hs | 103 +++++---- lib/Internal/Utils.hs | 376 ++++++++++++++++++++------------- 7 files changed, 521 insertions(+), 342 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 7a98ed8..a4847bd 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs index 78a10a4..c635fbb 100644 --- a/lib/Internal/Budget.hs +++ b/lib/Internal/Budget.hs @@ -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 diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs index 7617512..a376588 100644 --- a/lib/Internal/Database.hs +++ b/lib/Internal/Database.hs @@ -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] diff --git a/lib/Internal/Types/Database.hs b/lib/Internal/Types/Database.hs index 9df0bc4..516931b 100644 --- a/lib/Internal/Types/Database.hs +++ b/lib/Internal/Types/Database.hs @@ -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 diff --git a/lib/Internal/Types/Dhall.hs b/lib/Internal/Types/Dhall.hs index 31eadd0..474f448 100644 --- a/lib/Internal/Types/Dhall.hs +++ b/lib/Internal/Types/Dhall.hs @@ -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 diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs index c02606d..50e8eb7 100644 --- a/lib/Internal/Types/Main.hs +++ b/lib/Internal/Types/Main.hs @@ -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) diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index 059cd10..84a3dd9 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -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