ndwarshuis
/
pwncash
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

FIX rounding errors

This commit is contained in:
Nathan Dwarshuis 2023-07-06 00:05:16 -04:00
parent dce3ff4166
commit 24bc9a239b
4 changed files with 55 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
app/Main.hs
View File

@ -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

19
lib/Internal/Database.hs
View File

@ -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

2
lib/Internal/Types/Main.hs
View File

@ -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

52
lib/Internal/Utils.hs
View File

@ -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