ENH ensure tx sort order is (kinda) stable

lib/Internal/Budget.hs

@@ -153,13 +153,9 @@ readIncome
                 }
         return $
           Tx
-            { txCommit = key
+            { txMeta = TxMeta day incPriority (TxDesc "") key
-            , txDate = day
             , txPrimary = Left primary
             , txOther = []
-            , txDesc = TxDesc ""
-            , -- , txBudget = name
-              txPriority = incPriority
             }
 
 periodScaler
@@ -358,25 +354,28 @@ fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch
     shaRes = liftExcept $ shadowMatches stMatch tx
 
 shadowMatches :: TransferMatcher -> Tx CommitR -> AppExcept Bool
-shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} Tx {txPrimary, txDate} = do
+shadowMatches
-  -- NOTE this will only match against the primary entry set since those
+  TransferMatcher {tmFrom, tmTo, tmDate, tmVal}
-  -- are what are guaranteed to exist from a transfer
+  Tx {txPrimary, txMeta = TxMeta {txmDate}} =
-  valRes <- case txPrimary of
+    do
-    Left es -> valMatches tmVal $ toRational $ esTotalValue es
+      -- NOTE this will only match against the primary entry set since those
-    Right _ -> return True
+      -- are what are guaranteed to exist from a transfer
-  return $
+      valRes <- case txPrimary of
-    memberMaybe fa tmFrom
+        Left es -> valMatches tmVal $ toRational $ esTotalValue es
-      && memberMaybe ta tmTo
+        Right _ -> return True
-      && maybe True (`dateMatches` txDate) tmDate
+      return $
-      && valRes
+        memberMaybe fa tmFrom
-  where
+          && memberMaybe ta tmTo
-    fa = either getAcntFrom getAcntFrom txPrimary
+          && maybe True (`dateMatches` txmDate) tmDate
-    ta = either getAcntTo getAcntTo txPrimary
+          && valRes
-    getAcntFrom = getAcnt esFrom
+    where
-    getAcntTo = getAcnt esTo
+      fa = either getAcntFrom getAcntFrom txPrimary
-    getAcnt f = eAcnt . hesPrimary . f
+      ta = either getAcntTo getAcntTo txPrimary
-    memberMaybe x AcntSet {asList, asInclude} =
+      getAcntFrom = getAcnt esFrom
-      (if asInclude then id else not) $ x `elem` (AcntID <$> asList)
+      getAcntTo = getAcnt esTo
+      getAcnt f = eAcnt . hesPrimary . f
+      memberMaybe x AcntSet {asList, asInclude} =
+        (if asInclude then id else not) $ x `elem` (AcntID <$> asList)
 
 --------------------------------------------------------------------------------
 -- random

lib/Internal/Database.hs

@@ -469,6 +469,7 @@ updateCD (CRUDOps cs () () ds) = do
   mapM_ deleteKeyE ds
   insertEntityManyE cs
 
+-- TODO defer foreign keys so I don't need to confusingly reverse this stuff
 deleteTxs :: MonadSqlQuery m => DeleteTxs -> m ()
 deleteTxs DeleteTxs {dtTxs, dtEntrySets, dtEntries, dtTagRelations, dtCommits} = do
   mapM_ deleteKeyE dtTagRelations
@@ -566,8 +567,10 @@ readUpdates hashes = do
       ,
         (
           ( entrysets ^. EntrySetRId
+          , entrysets ^. EntrySetRIndex
           , txs ^. TransactionRDate
           , txs ^. TransactionRPriority
+          , txs ^. TransactionRDescription
           ,
             ( entrysets ^. EntrySetRCurrency
             , currencies ^. CurrencyRPrecision
@@ -577,11 +580,12 @@ readUpdates hashes = do
         )
       )
   let (toUpdate, toRead) = L.partition (E.unValue . fst) xs
-  toUpdate' <- liftExcept $ mapErrors makeUES $ groupKey (\(i, _, _, _) -> i) (snd <$> toUpdate)
+  toUpdate' <- liftExcept $ mapErrors makeUES $ groupKey (\(i, _, _, _, _, _) -> i) (snd <$> toUpdate)
   let toRead' = fmap (makeRE . snd) toRead
   return (toRead', toUpdate')
   where
-    makeUES ((_, day, pri, (curID, prec)), es) = do
+    makeUES ((_, esi, day, pri, desc, (curID, prec)), es) = do
+      let sk = TxSortKey (E.unValue day) (E.unValue pri) (E.unValue desc)
       let prec' = fromIntegral $ E.unValue prec
       let cur = E.unValue curID
       let res =
@@ -599,8 +603,7 @@ readUpdates hashes = do
             Left x ->
               Left $
                 UpdateEntrySet
-                  { utDate = E.unValue day
+                  { utCurrency = cur
-                  , utCurrency = cur
                   , utFrom0 = x
                   , utTo0 = to0
                   , utFromRO = fromRO
@@ -608,13 +611,13 @@ readUpdates hashes = do
                   , utFromUnk = fromUnk
                   , utToUnk = toUnk
                   , utTotalValue = realFracToDecimalP prec' tot
-                  , utPriority = E.unValue pri
+                  , utSortKey = sk
+                  , utIndex = E.unValue esi
                   }
             Right x ->
               Right $
                 UpdateEntrySet
-                  { utDate = E.unValue day
+                  { utCurrency = cur
-                  , utCurrency = cur
                   , utFrom0 = x
                   , utTo0 = to0
                   , utFromRO = fromRO
@@ -622,18 +625,20 @@ readUpdates hashes = do
                   , utFromUnk = fromUnk
                   , utToUnk = toUnk
                   , utTotalValue = ()
-                  , utPriority = E.unValue pri
+                  , utSortKey = sk
+                  , utIndex = E.unValue esi
                   }
         -- TODO this error is lame
         _ -> throwAppError $ DBError DBUpdateUnbalanced
-    makeRE ((_, day, pri, (curID, prec)), entry) = do
+    makeRE ((_, esi, day, pri, desc, (curID, prec)), entry) = do
       let e = entityVal entry
        in ReadEntry
-            { reDate = E.unValue day
+            { reCurrency = E.unValue curID
-            , reCurrency = E.unValue curID
             , reAcnt = entryRAccount e
             , reValue = realFracToDecimal (fromIntegral $ E.unValue prec) (entryRValue e)
-            , rePriority = E.unValue pri
+            , reSortKey = TxSortKey (E.unValue day) (E.unValue pri) (E.unValue desc)
+            , reESIndex = E.unValue esi
+            , reIndex = entryRIndex e
             }
 
 splitFrom
@@ -792,7 +797,7 @@ insertBudgets (CRUDOps bs () () ds) = do
       -- TODO useless overhead?
       (toUpdate, toInsert) <- balanceTxs (ToInsert <$> cs)
       mapM_ updateTx toUpdate
-      forM_ (groupWith itxCommit toInsert) $
+      forM_ (groupWith (txmCommit . itxMeta) toInsert) $
         \(c, ts) -> do
           ck <- insert c
           mapM_ (insertTx name ck) ts
@@ -804,7 +809,7 @@ insertHistory
 insertHistory (CRUDOps cs rs us ds) = do
   (toUpdate, toInsert) <- balanceTxs $ (ToInsert <$> cs) ++ (ToRead <$> rs) ++ (ToUpdate <$> us)
   mapM_ updateTx toUpdate
-  forM_ (groupWith itxCommit toInsert) $
+  forM_ (groupWith (txmCommit . itxMeta) toInsert) $
     \(c, ts) -> do
       ck <- insert c
       mapM_ (insertTx historyName ck) ts
@@ -829,8 +834,8 @@ insertHistory (CRUDOps cs rs us ds) = do
 --   deleteTxs ds
 
 insertTx :: MonadSqlQuery m => BudgetName -> CommitRId -> InsertTx -> m ()
-insertTx b c InsertTx {itxDate, itxDesc, itxEntrySets, itxPriority} = do
+insertTx b c InsertTx {itxMeta = TxMeta {txmDate, txmPriority, txmDesc}, itxEntrySets} = do
-  k <- insert $ TransactionR c itxDate b itxDesc itxPriority
+  k <- insert $ TransactionR c txmDate b txmDesc txmPriority
   mapM_ (uncurry (insertEntrySet k)) $ zip [0 ..] (NE.toList itxEntrySets)
   where
     insertEntrySet tk i InsertEntrySet {iesCurrency, iesFromEntries, iesToEntries} = do

lib/Internal/History.hs

@@ -72,9 +72,10 @@ readHistStmt
 readHistStmt root i = do
   bounds <- asks (unHSpan . tsHistoryScope)
   bs <- readImport root i
-  return $ filter (inDaySpan bounds . txDate) . fmap (\t -> t {txCommit = c}) <$> bs
+  return $ filter (inDaySpan bounds . txmDate . txMeta) . fmap go <$> bs
   where
-    c = CommitR (CommitHash $ hash i) CTHistoryStatement
+    go t@Tx {txMeta = m} =
+      t {txMeta = m {txmCommit = CommitR (CommitHash $ hash i) CTHistoryStatement}}
 
 -- TODO this probably won't scale well (pipes?)
 readImport
@@ -319,9 +320,7 @@ toTx
   r@TxRecord {trAmount, trDate, trDesc} = do
     combineError curRes subRes $ \(cur, f, t) ss ->
       Tx
-        { txDate = trDate
+        { txMeta = TxMeta trDate priority trDesc ()
-        , txDesc = trDesc
-        , txCommit = ()
         , txPrimary =
             Left $
               EntrySet
@@ -331,7 +330,6 @@ toTx
                 , esTo = t
                 }
         , txOther = Left <$> ss
-        , txPriority = priority
         }
     where
       curRes = do

lib/Internal/Types/Database.hs

@@ -24,10 +24,12 @@ CommitR sql=commits
     type ConfigType
     UniqueCommitHash hash
     deriving Show Eq Ord
+
 ConfigStateR sql=config_state
     historySpan HistorySpan
     budgetSpan BudgetSpan
     deriving Show
+
 CurrencyR sql=currencies
     symbol CurID
     fullname T.Text
@@ -35,12 +37,14 @@ CurrencyR sql=currencies
     UniqueCurrencySymbol symbol
     UniqueCurrencyFullname fullname
     deriving Show Eq Ord
+
 TagR sql=tags
     symbol TagID
     fullname T.Text
     UniqueTagSymbol symbol
     UniqueTagFullname fullname
     deriving Show Eq Ord
+
 AccountR sql=accounts
     name T.Text
     fullpath AcntPath
@@ -49,11 +53,13 @@ AccountR sql=accounts
     leaf Bool
     UniqueAccountFullpath fullpath
     deriving Show Eq Ord
+
 AccountPathR sql=account_paths
     parent AccountRId 
     child AccountRId 
     depth Int
     deriving Show Eq Ord
+
 TransactionR sql=transactions
     commit CommitRId 
     date Day
@@ -61,12 +67,14 @@ TransactionR sql=transactions
     description TxDesc
     priority Int
     deriving Show Eq
+
 EntrySetR sql=entry_sets
     transaction TransactionRId 
     currency CurrencyRId 
     index EntrySetIndex
     rebalance Bool
     deriving Show Eq
+
 EntryR sql=entries
     entryset EntrySetRId  
     account AccountRId 
@@ -77,12 +85,16 @@ EntryR sql=entries
     cachedType (Maybe TransferType)
     cachedLink (Maybe EntryIndex)
     deriving Show Eq
+
 TagRelationR sql=tag_relations
     entry EntryRId 
     tag TagRId
     deriving Show Eq
 |]
 
+newtype TxIndex = TxIndex {unTxIndex :: Int}
+  deriving newtype (Show, Eq, Ord, Num, Real, Enum, Integral, PersistField, PersistFieldSql)
+
 newtype EntrySetIndex = EntrySetIndex {unEntrySetIndex :: Int}
   deriving newtype (Show, Eq, Ord, Num, Real, Enum, Integral, PersistField, PersistFieldSql)
 

lib/Internal/Types/Main.hs

@@ -102,14 +102,22 @@ data CachedEntry
   | CachedBalance Decimal
   | CachedPercent Double
 
+data TxSortKey = TxSortKey
+  { tskDate :: !Day
+  , tskPriority :: !Int
+  , tskDesc :: !TxDesc
+  }
+  deriving (Show, Eq, Ord)
+
 -- TODO this should actually be a ReadTx since it will be compared with other
 -- Tx's to get the insert/update order correct
 data ReadEntry = ReadEntry
   { reCurrency :: !CurrencyRId
   , reAcnt :: !AccountRId
   , reValue :: !Decimal
-  , reDate :: !Day
+  , reIndex :: !EntryIndex
-  , rePriority :: !Int
+  , reESIndex :: !EntrySetIndex
+  , reSortKey :: !TxSortKey
   }
   deriving (Show)
 
@@ -149,9 +157,9 @@ data UpdateEntrySet f t = UpdateEntrySet
   , utFromRO :: ![UE_RO]
   , utToRO :: ![UE_RO]
   , utCurrency :: !CurrencyRId
-  , utDate :: !Day
   , utTotalValue :: !t
-  , utPriority :: !Int
+  , utIndex :: !EntrySetIndex
+  , utSortKey :: !TxSortKey
   }
   deriving (Show)
 
@@ -214,13 +222,18 @@ type ShadowEntrySet = TotalEntrySet Double EntryValue EntryLink
 data TxCommit = HistoryCommit CommitR | BudgetCommit CommitR T.Text
   deriving (Eq, Ord, Show)
 
+data TxMeta k = TxMeta
+  { txmDate :: !Day
+  , txmPriority :: !Int
+  , txmDesc :: !TxDesc
+  , txmCommit :: !k
+  }
+  deriving (Show, Eq, Ord)
+
 data Tx k = Tx
-  { txDesc :: !TxDesc
+  { txMeta :: !(TxMeta k)
-  , txDate :: !Day
-  , txPriority :: !Int
   , txPrimary :: !(Either PrimaryEntrySet TransferEntrySet)
   , txOther :: ![Either SecondayEntrySet ShadowEntrySet]
-  , txCommit :: !k
   }
   deriving (Generic, Show)
 
@@ -236,11 +249,8 @@ data InsertEntrySet = InsertEntrySet
   }
 
 data InsertTx = InsertTx
-  { itxDesc :: !TxDesc
+  { itxMeta :: !(TxMeta CommitR)
-  , itxDate :: !Day
-  , itxPriority :: !Int
   , itxEntrySets :: !(NonEmpty InsertEntrySet)
-  , itxCommit :: !CommitR
   }
   deriving (Generic)
 

lib/Internal/Utils.hs

@@ -642,19 +642,11 @@ balanceTxs ebs =
     go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do
       modify $ mapAdd_ (reAcnt, reCurrency) reValue
       return Nothing
-    go (ToInsert Tx {txPrimary, txOther, txDesc, txCommit, txDate, txPriority}) = do
+    go (ToInsert Tx {txPrimary, txOther, txMeta}) = do
       e <- either balancePrimaryEntrySet balanceSecondaryEntrySet txPrimary
       let tot = sum $ fmap (eValue . ieEntry) $ NE.toList $ iesFromEntries e
       es <- mapErrors (goOther tot) txOther
-      let tx =
+      let tx = InsertTx {itxMeta = txMeta, itxEntrySets = e :| es}
-            -- TODO this is lame
-            InsertTx
-              { itxDesc = txDesc
-              , itxDate = txDate
-              , itxEntrySets = e :| es
-              , itxCommit = txCommit
-              , itxPriority = txPriority
-              }
       return $ Just $ Right tx
       where
         goOther tot =
@@ -663,12 +655,20 @@ balanceTxs ebs =
             (balancePrimaryEntrySet . fromShadow tot)
         fromShadow tot e@EntrySet {esTotalValue} = e {esTotalValue = tot *. esTotalValue}
 
-binDate :: EntryCRU -> (Day, Int)
+-- NOTE this sorting thing is super wonky; I'm basically sorting three different
-binDate (ToRead ReadEntry {reDate, rePriority}) = (reDate, rePriority)
+-- levels of the hierarchy directory and assuming there will be no overlaps.
-binDate (ToInsert Tx {txDate, txPriority}) = (txDate, txPriority)
+-- First, sort at the transaction level by day, priority, and description as
+-- tiebreaker. Anything that shares those three keys will have an unstable sort
+-- order. Within the entrysets, use the index as it appears in the
+-- configuration, and same with the entries. Since we assume no overlap, nothing
+-- "bad" should happen if the levels above entries/entrysets sort on 'Nothing'
+-- for the indices they don't have at their level.
+binDate :: EntryCRU -> (TxSortKey, Maybe EntrySetIndex, Maybe EntryIndex)
+binDate (ToRead ReadEntry {reSortKey, reESIndex, reIndex}) = (reSortKey, Just reESIndex, Just reIndex)
+binDate (ToInsert Tx {txMeta = (TxMeta t p d _)}) = (TxSortKey t p d, Nothing, Nothing)
 binDate (ToUpdate u) = either go go u
   where
-    go UpdateEntrySet {utDate, utPriority} = (utDate, utPriority)
+    go UpdateEntrySet {utSortKey, utIndex} = (utSortKey, Just utIndex, Nothing)
 
 type BCKey = CurrencyRId
 
@@ -988,12 +988,9 @@ expandTransfer tc bounds Transfer {transAmounts, transTo, transCurrency, transFr
         withDates bounds pat $ \day ->
           return
             Tx
-              { txCommit = tc
+              { txMeta = TxMeta day (fromIntegral pri) (TxDesc desc) tc
-              , txDate = day
               , txPrimary = Right $ entryPair transFrom transTo (cpID cp) desc () v''
               , txOther = []
-              , txDesc = TxDesc desc
-              , txPriority = fromIntegral pri
               }
 
 entryPair