ADD priority flag to keep tx's sorted always

dhall/Types.dhall

@@ -679,7 +679,7 @@ let Amount =
     -}
       \(w : Type) ->
       \(v : Type) ->
-        { amtWhen : w, amtValue : v, amtDesc : Text }
+        { amtWhen : w, amtValue : v, amtDesc : Text, amtPriority : Integer }
 
 let TransferType =
     {-
@@ -967,11 +967,13 @@ let Income =
               (if any) after all allocations have been applied.
               -}
               TaggedAcnt.Type
+          , incPriority : Integer
           }
       , default =
         { incPretax = [] : List (SingleAllocation PretaxValue)
         , incTaxes = [] : List (SingleAllocation TaxValue)
         , incPosttaxx = [] : List (SingleAllocation PosttaxValue)
+        , incPriority = +0
         }
       }
 

lib/Internal/Budget.hs

@@ -92,29 +92,30 @@ readIncome
   Income
     { incWhen
     , incCurrency
-    , incFrom
+    , incFrom = TaggedAcnt {taAcnt = srcAcnt, taTags = srcTags}
     , incPretax
     , incPosttax
     , incTaxes
-    , incToBal
+    , incToBal = TaggedAcnt {taAcnt = destAcnt, taTags = destTags}
     , incGross
     , incPayPeriod
+    , incPriority
     } =
     combineErrorM
       (combineError incRes nonIncRes (,))
-      (combineError precRes dayRes (,))
+      (combineError cpRes dayRes (,))
-      $ \_ (precision, days) -> do
+      $ \_ (cp, days) -> do
-        let gross = roundPrecision precision incGross
+        let gross = roundPrecisionCur cp incGross
-        concat <$> foldDays (allocate precision gross) start days
+        foldDays (allocate cp gross) start days
     where
-      incRes = isIncomeAcnt $ taAcnt incFrom
+      incRes = isIncomeAcnt srcAcnt
       nonIncRes =
         mapErrors isNotIncomeAcnt $
-          taAcnt incToBal
+          destAcnt
             : (alloAcnt <$> incPretax)
             ++ (alloAcnt <$> incTaxes)
             ++ (alloAcnt <$> incPosttax)
-      precRes = lookupCurrencyPrec incCurrency
+      cpRes = lookupCurrency incCurrency
       dayRes = liftExcept $ expandDatePat ds incWhen
       start = fromGregorian' $ pStart incPayPeriod
       pType' = pType incPayPeriod
@@ -123,8 +124,9 @@ readIncome
       flatPost = concatMap flattenAllo incPosttax
       sumAllos = sum . fmap faValue
       -- TODO ensure these are all the "correct" accounts
-      allocate precision gross prevDay day = do
+      allocate cp gross prevDay day = do
         scaler <- liftExcept $ periodScaler pType' prevDay day
+        let precision = cpPrec cp
         let (preDeductions, pre) =
               allocatePre precision gross $
                 flatPre ++ concatMap (selectAllos day) intPre
@@ -135,31 +137,39 @@ readIncome
         let post =
               allocatePost precision aftertaxGross $
                 flatPost ++ concatMap (selectAllos day) intPost
-        let balance = aftertaxGross - sumAllos post
         -- TODO double or rational here?
-        primary <-
+        let src =
-          entryPair
+              Entry
-            incFrom
+                { eAcnt = srcAcnt
-            incToBal
+                , eValue = ()
-            incCurrency
+                , eComment = ""
-            "balance after deductions"
+                , eTags = srcTags
-            (fromRational balance)
-            ()
-        -- TODO make this into one large tx?
-        allos <- mapErrors (allo2Trans key name day incFrom) (pre ++ tax ++ post)
-        let bal =
-              Tx
-                { txCommit = key
-                , txDate = day
-                , txPrimary = Left primary
-                , txOther = []
-                , txDescr = "balance after deductions"
-                , txBudget = name
                 }
-        -- TODO use real name here
+        let dest =
-        if balance < 0
+              Entry
-          then throwError $ InsertException [IncomeError day name balance]
+                { eAcnt = destAcnt
-          else return (bal : allos)
+                , eValue = ()
+                , eComment = "balance after deductions"
+                , eTags = destTags
+                }
+        let allos = allo2Trans <$> (pre ++ tax ++ post)
+        let primary =
+              EntrySet
+                { esTotalValue = gross
+                , esCurrency = cp
+                , esFrom = HalfEntrySet {hesPrimary = src, hesOther = []}
+                , esTo = HalfEntrySet {hesPrimary = dest, hesOther = allos}
+                }
+        return $
+          Tx
+            { txCommit = key
+            , txDate = day
+            , txPrimary = Left primary
+            , txOther = []
+            , txDescr = ""
+            , txBudget = name
+            , txPriority = incPriority
+            }
 
 periodScaler
   :: PeriodType
@@ -236,49 +246,35 @@ checkAcntTypes ts i = void $ go =<< lookupAccountType i
       | otherwise = throwError $ InsertException [AccountError i ts]
 
 flattenAllo :: SingleAllocation v -> [FlatAllocation v]
-flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts
+flattenAllo Allocation {alloAmts, alloTo} = fmap go alloAmts
   where
     go Amount {amtValue, amtDesc} =
       FlatAllocation
-        { faCur = alloCur
+        { faTo = alloTo
-        , faTo = alloTo
         , faValue = amtValue
         , faDesc = amtDesc
         }
 
 -- ASSUME allocations are sorted
 selectAllos :: Day -> DaySpanAllocation v -> [FlatAllocation v]
-selectAllos day Allocation {alloAmts, alloCur, alloTo} =
+selectAllos day Allocation {alloAmts, alloTo} =
   go <$> filter ((`inDaySpan` day) . amtWhen) alloAmts
   where
     go Amount {amtValue, amtDesc} =
       FlatAllocation
-        { faCur = alloCur
+        { faTo = alloTo
-        , faTo = alloTo
         , faValue = amtValue
         , faDesc = amtDesc
         }
 
-allo2Trans
+allo2Trans :: FlatAllocation Rational -> Entry AcntID (LinkDeferred Rational) TagID
-  :: (MonadInsertError m, MonadFinance m)
+allo2Trans FlatAllocation {faValue, faTo = TaggedAcnt {taAcnt, taTags}, faDesc} =
-  => CommitR
+  Entry
-  -> T.Text
+    { eValue = LinkDeferred (EntryValue TFixed faValue)
-  -> Day
+    , eComment = faDesc
-  -> TaggedAcnt
+    , eAcnt = taAcnt
-  -> FlatAllocation Rational
+    , eTags = taTags
-  -> m (Tx CommitR)
+    }
-allo2Trans meta name day from FlatAllocation {faValue, faTo, faDesc, faCur} = do
-  -- TODO double here?
-  p <- entryPair from faTo faCur faDesc (fromRational faValue) ()
-  return
-    Tx
-      { txCommit = meta
-      , txDate = day
-      , txPrimary = Left p
-      , txOther = []
-      , txDescr = faDesc
-      , txBudget = name
-      }
 
 allocatePre
   :: Natural
@@ -414,6 +410,5 @@ data FlatAllocation v = FlatAllocation
   { faValue :: !v
   , faDesc :: !T.Text
   , faTo :: !TaggedAcnt
-  , faCur :: !CurID
   }
   deriving (Functor, Show)

lib/Internal/Database.hs

@@ -447,6 +447,7 @@ readUpdates hashes = do
           ( entrysets ^. EntrySetRId
           , txs ^. TransactionRDate
           , txs ^. TransactionRBudgetName
+          , txs ^. TransactionRPriority
           ,
             ( entrysets ^. EntrySetRCurrency
             , currencies ^. CurrencyRPrecision
@@ -456,10 +457,10 @@ 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)
   return (makeRE . snd <$> toRead, toUpdate')
   where
-    makeUES ((_, day, name, (curID, prec)), es) = do
+    makeUES ((_, day, name, pri, (curID, prec)), es) = do
       let res =
             bimap NE.nonEmpty NE.nonEmpty $
               NE.partition ((< 0) . entryRIndex . snd) $
@@ -485,6 +486,7 @@ readUpdates hashes = do
                   , utToUnk = toUnk
                   , utTotalValue = tot
                   , utBudget = E.unValue name
+                  , utPriority = E.unValue pri
                   }
             Right x ->
               Right $
@@ -499,9 +501,10 @@ readUpdates hashes = do
                   , utToUnk = toUnk
                   , utTotalValue = ()
                   , utBudget = E.unValue name
+                  , utPriority = E.unValue pri
                   }
         _ -> throwError undefined
-    makeRE ((_, day, name, (curID, _)), entry) =
+    makeRE ((_, day, name, pri, (curID, _)), entry) =
       let e = entityVal entry
        in ReadEntry
             { reDate = E.unValue day
@@ -509,6 +512,7 @@ readUpdates hashes = do
             , reAcnt = entryRAccount e
             , reValue = entryRValue e
             , reBudget = E.unValue name
+            , rePriority = E.unValue pri
             }
 
 splitFrom
@@ -660,8 +664,8 @@ insertAll ebs = do
 --   getCommit (BudgetCommit c _) = c
 
 insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m ()
-insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxBudget} = do
+insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxBudget, itxPriority} = do
-  k <- insert $ TransactionR c itxDate itxDescr itxBudget
+  k <- insert $ TransactionR c itxDate itxDescr itxBudget itxPriority
   mapM_ (uncurry (insertEntrySet k)) $ zip [0 ..] (NE.toList itxEntrySets)
   where
     insertEntrySet tk i InsertEntrySet {iesCurrency, iesFromEntries, iesToEntries} = do

lib/Internal/History.hs

@@ -267,7 +267,7 @@ matchNonDates ms = go ([], [], initZipper ms)
 
 matches :: MonadFinance m => MatchRe -> TxRecord -> InsertExceptT m (MatchRes (Tx ()))
 matches
-  StatementParser {spTx, spOther, spVal, spDate, spDesc}
+  StatementParser {spTx, spOther, spVal, spDate, spDesc, spPriority}
   r@TxRecord {trDate, trAmount, trDesc, trOther} = do
     res <- liftInner $
       combineError3 val other desc $
@@ -280,10 +280,11 @@ matches
       date = maybe True (`dateMatches` trDate) spDate
       other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True spOther
       desc = maybe (return True) (matchMaybe trDesc . snd) spDesc
-      convert tg = MatchPass <$> toTx tg r
+      convert tg = MatchPass <$> toTx (fromIntegral spPriority) tg r
 
-toTx :: MonadFinance m => TxGetter -> TxRecord -> InsertExceptT m (Tx ())
+toTx :: MonadFinance m => Int -> TxGetter -> TxRecord -> InsertExceptT m (Tx ())
 toTx
+  priority
   TxGetter
     { tgFrom
     , tgTo
@@ -305,8 +306,9 @@ toTx
                 , esFrom = f
                 , esTo = t
                 }
-        , txOther = fmap Left ss
+        , txOther = Left <$> ss
         , txBudget = historyName
+        , txPriority = priority
         }
     where
       curRes = do

lib/Internal/Types/Database.hs

@@ -45,6 +45,7 @@ TransactionR sql=transactions
     date Day
     description T.Text
     budgetName T.Text
+    priority Int
     deriving Show Eq
 EntrySetR sql=entry_sets
     transaction TransactionRId OnDeleteCascade

lib/Internal/Types/Dhall.hs

@@ -243,6 +243,7 @@ data Income = Income
   , incFrom :: TaggedAcnt
   , incToBal :: TaggedAcnt
   , incPayPeriod :: !Period
+  , incPriority :: !Int
   }
 
 deriving instance Hashable HourlyPeriod

lib/Internal/Types/Main.hs

@@ -76,6 +76,7 @@ data ReadEntry = ReadEntry
   , reAcnt :: !AccountRId
   , reValue :: !Rational
   , reDate :: !Day
+  , rePriority :: !Int
   , reBudget :: !T.Text
   }
   deriving (Show)
@@ -124,6 +125,7 @@ data UpdateEntrySet f t = UpdateEntrySet
   , utDate :: !Day
   , utTotalValue :: !t
   , utBudget :: !T.Text
+  , utPriority :: !Int
   }
   deriving (Show)
 
@@ -245,6 +247,7 @@ data TxCommit = HistoryCommit CommitR | BudgetCommit CommitR T.Text
 data Tx k = Tx
   { txDescr :: !T.Text
   , txDate :: !Day
+  , txPriority :: !Int
   , txPrimary :: !(Either PrimaryEntrySet TransferEntrySet)
   , txOther :: ![Either SecondayEntrySet ShadowEntrySet]
   , txCommit :: !k
@@ -266,6 +269,7 @@ data InsertEntrySet = InsertEntrySet
 data InsertTx = InsertTx
   { itxDescr :: !T.Text
   , itxDate :: !Day
+  , itxPriority :: !Int
   , itxEntrySets :: !(NonEmpty InsertEntrySet)
   , itxCommit :: !CommitR
   , itxBudget :: !T.Text

lib/Internal/Utils.hs

@@ -692,7 +692,7 @@ balanceTxs ebs =
     go (ToRead ReadEntry {reCurrency, reAcnt, reValue, reBudget}) = do
       modify $ mapAdd_ (reAcnt, (reCurrency, reBudget)) reValue
       return Nothing
-    go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate, txBudget}) = do
+    go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate, txBudget, txPriority}) = do
       e <- either (balancePrimaryEntrySet txBudget) (balanceSecondaryEntrySet txBudget) txPrimary
       let tot = sum $ fmap (eValue . ieEntry) $ NE.toList $ iesFromEntries e
       es <- mapErrors (either (balanceSecondaryEntrySet txBudget) (balancePrimaryEntrySet txBudget . fromShadow tot)) txOther
@@ -704,15 +704,17 @@ balanceTxs ebs =
               , itxEntrySets = e :| es
               , itxCommit = txCommit
               , itxBudget = txBudget
+              , itxPriority = txPriority
               }
       return $ Just $ Right tx
     fromShadow tot e@EntrySet {esTotalValue} = e {esTotalValue = tot * toRational esTotalValue}
 
-binDate :: EntryBin -> Day
+binDate :: EntryBin -> (Day, Int)
-binDate (ToUpdate (Right UpdateEntrySet {utDate})) = utDate
+binDate (ToRead ReadEntry {reDate, rePriority}) = (reDate, rePriority)
-binDate (ToUpdate (Left UpdateEntrySet {utDate})) = utDate
+binDate (ToInsert Tx {txDate, txPriority}) = (txDate, txPriority)
-binDate (ToRead ReadEntry {reDate}) = reDate
+binDate (ToUpdate u) = either go go u
-binDate (ToInsert Tx {txDate}) = txDate
+  where
+    go UpdateEntrySet {utDate, utPriority} = (utDate, utPriority)
 
 type BCKey = (CurrencyRId, Text)
 
@@ -1044,6 +1046,7 @@ expandTransfer tc name bounds Transfer {transAmounts, transTo, transCurrency, tr
         { amtWhen = pat
         , amtValue = TransferValue {tvVal = v, tvType = t}
         , amtDesc = desc
+        , amtPriority = pri
         } =
         withDates bounds pat $ \day -> do
           p <- entryPair transFrom transTo transCurrency desc () (EntryValue t (toRational (-v)))
@@ -1055,6 +1058,7 @@ expandTransfer tc name bounds Transfer {transAmounts, transTo, transCurrency, tr
               , txOther = []
               , txDescr = desc
               , txBudget = name
+              , txPriority = fromIntegral pri
               }
 
 entryPair