FIX rounding errors

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

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

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

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
+      (ftot, fs, tpairs) <- rebalanceDebit bc precision rs ls
-      ts <- rebalanceCredit bc ftot utTo0 utToUnk utToRO tpairs
+      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 :: Natural -> BCKey -> UpdateEntry i EntryValueUnk -> State EntryBals Rational
-updateUnknown k e = do
+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
+balanceDeferred prec k (EntryValue t v) = do
-  newval <- findBalance k t v
+  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