From 24bc9a239bf8f061300f90c78f6ba40982ec892d Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Thu, 6 Jul 2023 00:05:16 -0400 Subject: [PATCH] FIX rounding errors --- app/Main.hs | 14 ++++++++++ lib/Internal/Database.hs | 19 +++++++++----- lib/Internal/Types/Main.hs | 2 +- lib/Internal/Utils.hs | 52 ++++++++++++++++++++------------------ 4 files changed, 55 insertions(+), 32 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 4c61c7b..60c403e 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -178,17 +178,31 @@ runSync c = do flip runReaderT state $ do let (hTs, hSs) = splitHistory $ statements config hSs' <- mapErrorsIO (readHistStmt root) hSs + -- lift $ print $ length $ lefts hSs' + -- lift $ print $ length $ rights hSs' hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs + -- lift $ print $ length $ lefts hTs' bTs <- liftIOExceptT $ mapErrors readBudget $ budget config + -- lift $ print $ length $ lefts bTs return $ second concat $ partitionEithers $ hSs' ++ hTs' ++ bTs + -- print $ length $ kmNewCommits state + -- print $ length $ duOldCommits updates + -- print $ length $ duNewTagIds updates + -- print $ length $ duNewAcntPaths updates + -- print $ length $ duNewAcntIds updates + -- print $ length $ duNewCurrencyIds updates -- Update the DB. runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do -- NOTE this must come first (unless we defer foreign keys) updateDBState updates + -- TODO skip this entire section if the database won't change (eg length + -- of 'is' is zero and there are no commits to delete) res <- runExceptT $ do -- TODO taking out the hash is dumb (rs, ues) <- readUpdates $ fmap commitRHash rus + -- rerunnableIO $ print ues + -- rerunnableIO $ print $ length rs let ebs = fmap ToUpdate ues ++ fmap ToRead rs ++ fmap ToInsert is insertAll ebs -- NOTE this rerunnable thing is a bit misleading; fromEither will throw diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs index a0472f4..d680f0f 100644 --- a/lib/Internal/Database.hs +++ b/lib/Internal/Database.hs @@ -428,7 +428,7 @@ readUpdates -> m ([ReadEntry], [Either TotalUpdateEntrySet FullUpdateEntrySet]) readUpdates hashes = do xs <- selectE $ do - (commits :& txs :& entrysets :& entries) <- + (commits :& txs :& entrysets :& entries :& currencies) <- E.from $ E.table @CommitR `E.innerJoin` E.table @TransactionR @@ -437,6 +437,8 @@ readUpdates hashes = do `E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction) `E.innerJoin` E.table @EntryR `E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset) + `E.innerJoin` E.table @CurrencyR + `E.on` (\(_ :& _ :& es :& _ :& cur) -> es ^. EntrySetRCurrency ==. cur ^. CurrencyRId) E.where_ $ commits ^. CommitRHash `E.in_` E.valList hashes return ( entrysets ^. EntrySetRRebalance @@ -445,7 +447,10 @@ readUpdates hashes = do ( entrysets ^. EntrySetRId , txs ^. TransactionRDate , txs ^. TransactionRBudgetName - , entrysets ^. EntrySetRCurrency + , + ( entrysets ^. EntrySetRCurrency + , currencies ^. CurrencyRPrecision + ) ) , entries ) @@ -454,7 +459,7 @@ readUpdates hashes = do toUpdate' <- liftExcept $ mapErrors makeUES $ groupKey (\(i, _, _, _) -> i) (snd <$> toUpdate) return (makeRE . snd <$> toRead, toUpdate') where - makeUES ((_, day, name, curID), es) = do + makeUES ((_, day, name, (curID, prec)), es) = do let res = bimap NE.nonEmpty NE.nonEmpty $ NE.partition ((< 0) . entryRIndex . snd) $ @@ -471,7 +476,7 @@ readUpdates hashes = do Left $ UpdateEntrySet { utDate = E.unValue day - , utCurrency = E.unValue curID + , utCurrency = (E.unValue curID, fromIntegral $ E.unValue prec) , utFrom0 = x , utTo0 = to0 , utFromRO = fromRO @@ -485,7 +490,7 @@ readUpdates hashes = do Right $ UpdateEntrySet { utDate = E.unValue day - , utCurrency = E.unValue curID + , utCurrency = (E.unValue curID, fromIntegral $ E.unValue prec) , utFrom0 = x , utTo0 = to0 , utFromRO = fromRO @@ -496,7 +501,7 @@ readUpdates hashes = do , utBudget = E.unValue name } _ -> throwError undefined - makeRE ((_, day, name, curID), entry) = + makeRE ((_, day, name, (curID, _)), entry) = let e = entityVal entry in ReadEntry { reDate = E.unValue day @@ -671,7 +676,7 @@ insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxBudget} = do -- BudgetCommit _ name -> insert_ $ BudgetLabelR ek name -- _ -> return () -insertEntry :: MonadSqlQuery m => EntrySetRId -> Int -> KeyEntry -> m EntryRId +insertEntry :: MonadSqlQuery m => EntrySetRId -> Int -> InsertEntry -> m EntryRId insertEntry k i diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs index bc2e868..fb01374 100644 --- a/lib/Internal/Types/Main.hs +++ b/lib/Internal/Types/Main.hs @@ -120,7 +120,7 @@ data UpdateEntrySet f t = UpdateEntrySet , utToUnk :: ![UEUnk] , utFromRO :: ![UE_RO] , utToRO :: ![UE_RO] - , utCurrency :: !CurrencyRId + , utCurrency :: !(CurrencyRId, Natural) , utDate :: !Day , utTotalValue :: !t , utBudget :: !T.Text diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index b156ea6..fea403b 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -733,19 +733,19 @@ rebalanceTotalEntrySet , utToUnk , utFromRO , utToRO - , utCurrency + , utCurrency = (curID, precision) , utTotalValue , utBudget } = do - (fval, fs, tpairs) <- rebalanceDebit bc utFromRO utFromUnk + (fval, fs, tpairs) <- rebalanceDebit bc precision utFromRO utFromUnk let f0val = utTotalValue - fval modify $ mapAdd_ (f0Acnt, bc) f0val let tsLinked = tpairs ++ (unlink f0val <$> f0links) - ts <- rebalanceCredit bc utTotalValue utTo0 utToUnk utToRO tsLinked + ts <- rebalanceCredit bc precision utTotalValue utTo0 utToUnk utToRO tsLinked return (f0 {ueValue = StaticValue f0val} : fs ++ ts) where - bc = (utCurrency, utBudget) + bc = (curID, utBudget) rebalanceFullEntrySet :: FullUpdateEntrySet -> State EntryBals [UEBalanced] rebalanceFullEntrySet @@ -756,25 +756,26 @@ rebalanceFullEntrySet , utToUnk , utFromRO , utToRO - , utCurrency + , utCurrency = (curID, precision) , utBudget } = do - (ftot, fs, tpairs) <- rebalanceDebit bc rs ls - ts <- rebalanceCredit bc ftot utTo0 utToUnk utToRO tpairs + (ftot, fs, tpairs) <- rebalanceDebit bc precision rs ls + ts <- rebalanceCredit bc precision ftot utTo0 utToUnk utToRO tpairs return (fs ++ ts) where (rs, ls) = case utFrom0 of Left x -> (x : utFromRO, utFromUnk) Right x -> (utFromRO, x : utFromUnk) - bc = (utCurrency, utBudget) + bc = (curID, utBudget) rebalanceDebit :: BCKey + -> Natural -> [UE_RO] -> [(UEUnk, [UELink])] -> State EntryBals (Rational, [UEBalanced], [UEBalanced]) -rebalanceDebit k ro linked = do +rebalanceDebit k precision ro linked = do (tot, (tpairs, fs)) <- fmap (second (partitionEithers . concat)) $ sumM goFrom $ @@ -785,7 +786,7 @@ rebalanceDebit k ro linked = do idx = either ueIndex (ueIndex . fst) goFrom (Left e) = (,[]) <$> updateFixed k e goFrom (Right (e0, es)) = do - v <- updateUnknown k e0 + v <- updateUnknown precision k e0 let e0' = Right $ e0 {ueValue = StaticValue v} let es' = Left . unlink v <$> es return (v, e0' : es') @@ -795,13 +796,14 @@ unlink v e = e {ueValue = StaticValue $ (-v) * unLinkScale (ueValue e)} rebalanceCredit :: BCKey + -> Natural -> Rational -> UEBlank -> [UEUnk] -> [UE_RO] -> [UEBalanced] -> State EntryBals [UEBalanced] -rebalanceCredit k tot t0 us rs bs = do +rebalanceCredit k precision tot t0 us rs bs = do (tval, ts) <- fmap (second catMaybes) $ sumM goTo $ @@ -815,7 +817,7 @@ rebalanceCredit k tot t0 us rs bs = do goTo (UETReadOnly e) = (,Nothing) <$> updateFixed k e goTo (UETLinked e) = (,Just e) <$> updateFixed k e goTo (UETUnk e) = do - v <- updateUnknown k e + v <- updateUnknown precision k e return (v, Just $ e {ueValue = StaticValue v}) data UpdateEntryType a b @@ -834,11 +836,11 @@ updateFixed k e = do modify $ mapAdd_ (ueAcnt e, k) v return v -updateUnknown :: BCKey -> UpdateEntry i EntryValueUnk -> State EntryBals Rational -updateUnknown k e = do +updateUnknown :: Natural -> BCKey -> UpdateEntry i EntryValueUnk -> State EntryBals Rational +updateUnknown precision k e = do let key = (ueAcnt e, k) curBal <- gets (M.findWithDefault 0 key) - let v = case ueValue e of + let v = roundPrecision precision $ fromRational $ case ueValue e of EVPercent p -> p * curBal EVBalance p -> p - curBal modify $ mapAdd_ key v @@ -868,7 +870,7 @@ balancePrimaryEntrySet let bc = (curID, budgetName) combineErrorM (combineError f0res fsres (,)) (combineError t0res tsres (,)) $ \(f0', fs') (t0', ts') -> do - let balFrom = fmap liftInnerS . balanceDeferred + let balFrom = fmap liftInnerS . balanceDeferred precision fs'' <- doEntries balFrom bc esTotalValue f0' fs' balanceFinal bc (-esTotalValue) precision fs'' t0' ts' @@ -894,7 +896,7 @@ balanceSecondaryEntrySet balanceFinal bc (-tot) precision fs'' t0' ts' where entrySum = sum . fmap (eValue . ieEntry) - balFrom = balanceEntry (fmap liftInnerS . balanceDeferred) bc + balFrom = balanceEntry (fmap liftInnerS . balanceDeferred precision) bc bc = (curID, budgetName) balanceFinal @@ -958,16 +960,17 @@ balanceLinked from precision k lg = case lg of -- TODO this error would be much more informative if I had access to the -- file from which it came Nothing -> throwError undefined - (LinkDeferred d) -> liftInnerS $ balanceDeferred k d + (LinkDeferred d) -> liftInnerS $ balanceDeferred precision k d where go s = negate . roundPrecision precision . (* s) . fromRational balanceDeferred - :: ABCKey + :: Natural + -> ABCKey -> EntryValue Rational -> State EntryBals (Rational, Maybe DBDeferred) -balanceDeferred k (EntryValue t v) = do - newval <- findBalance k t v +balanceDeferred prec k (EntryValue t v) = do + newval <- findBalance prec k t v let d = case t of TFixed -> Nothing TBalance -> Just $ EntryBalance v @@ -1001,13 +1004,14 @@ resolveAcntAndTags e@Entry {eAcnt, eTags} = do \(acntID, sign, _) tags -> e {eAcnt = (acntID, sign), eTags = tags} findBalance - :: ABCKey + :: Natural + -> ABCKey -> TransferType -> Rational -> State EntryBals Rational -findBalance k t v = do +findBalance prec k t v = do curBal <- gets (M.findWithDefault 0 k) - return $ case t of + return $ roundPrecision prec $ fromRational $ case t of TBalance -> v - curBal TPercent -> v * curBal TFixed -> v