app/Main.hs

@@ -4,13 +4,18 @@ module Main (main) where
 
 import Control.Concurrent
 import Control.Monad.Except
+import Control.Monad.IO.Rerunnable
 import Control.Monad.Logger
+import Control.Monad.Reader
 import Data.Bitraversable
 -- import Data.Hashable
 import qualified Data.Text.IO as TI
 import qualified Database.Esqueleto.Experimental as E
+import Database.Persist.Monad
 import qualified Dhall hiding (double, record)
+import Internal.Budget
 import Internal.Database
+import Internal.History
 import Internal.Types.Main
 import Internal.Utils
 import Options.Applicative
@@ -67,7 +72,7 @@ options =
     <|> getConf dumpCurrencies
     <|> getConf dumpAccounts
     <|> getConf dumpAccountKeys
-    <|> getConf sync_
+    <|> getConf sync
   where
     getConf m = Options <$> configFile <*> m
 
@@ -108,8 +113,8 @@ dumpAccountKeys =
         <> help "Dump all account keys/aliases"
     )
 
-sync_ :: Parser Mode
+sync :: Parser Mode
-sync_ =
+sync =
   flag'
     Sync
     ( long "sync"
@@ -214,7 +219,40 @@ runSync threads c bs hs = do
   pool <- runNoLoggingT $ mkPool $ sqlConfig config
   putStrLn "doing other stuff"
   setNumCapabilities 1
-  handle err $ sync pool root config bs' hs'
+  handle err $ do
+    -- _ <- askLoggerIO
+
+    -- Get the current DB state.
+    state <- runSqlQueryT pool $ do
+      runMigration migrateAll
+      liftIOExceptT $ readConfigState config bs' hs'
+
+    -- Read raw transactions according to state. If a transaction is already in
+    -- the database, don't read it but record the commit so we can update it.
+    toIns <-
+      flip runReaderT state $ do
+        (CRUDOps hSs _ _ _) <- asks csHistStmts
+        hSs' <- mapErrorsIO (readHistStmt root) hSs
+        (CRUDOps hTs _ _ _) <- asks csHistTrans
+        hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs
+        (CRUDOps bTs _ _ _) <- asks csBudgets
+        bTs' <- liftIOExceptT $ mapErrors readBudget bTs
+        return $ concat $ hSs' ++ hTs' ++ bTs'
+
+    -- Update the DB.
+    runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
+      -- NOTE this must come first (unless we defer foreign keys)
+      updateDBState
+      res <- runExceptT $ do
+        (CRUDOps _ bRs bUs _) <- asks csBudgets
+        (CRUDOps _ tRs tUs _) <- asks csHistTrans
+        (CRUDOps _ sRs sUs _) <- asks csHistStmts
+        let ebs = fmap ToUpdate (bUs ++ tUs ++ sUs) ++ fmap ToRead (bRs ++ tRs ++ sRs) ++ fmap ToInsert toIns
+        insertAll ebs
+      -- NOTE this rerunnable thing is a bit misleading; fromEither will throw
+      -- whatever error is encountered above in an IO context, but the first
+      -- thrown error should be caught despite possibly needing to be rerun
+      rerunnableIO $ fromEither res
   where
     root = takeDirectory c
     err (AppException es) = do

dhall/Types.dhall

@@ -1069,6 +1069,7 @@ let ShadowTransfer =
           specified in other fields of this type.
           -}
           TransferMatcher.Type
+      , stType : TransferType
       , stRatio :
           {-
           Fixed multipler to translate value of matched transfer to this one.

lib/Internal/Budget.hs

@@ -1,4 +1,4 @@
-module Internal.Budget (readBudgetCRUD) where
+module Internal.Budget (readBudget) where
 
 import Control.Monad.Except
 import Data.Decimal hiding (allocate)
@@ -13,12 +13,7 @@ import qualified RIO.NonEmpty as NE
 import qualified RIO.Text as T
 import RIO.Time
 
-readBudgetCRUD :: (MonadAppError m, MonadFinance m) => PreBudgetCRUD -> m FinalBudgetCRUD
+readBudget :: (MonadAppError m, MonadFinance m) => Budget -> m [Tx CommitR]
-readBudgetCRUD o@CRUDOps {coCreate} = do
-  bs <- mapM readBudget coCreate
-  return $ o {coCreate = bs}
-
-readBudget :: (MonadAppError m, MonadFinance m) => Budget -> m (BudgetName, [Tx CommitR])
 readBudget
   b@Budget
     { bgtLabel
@@ -32,12 +27,12 @@ readBudget
     } =
     do
       spanRes <- getSpan
-      (bgtLabel,) <$> case spanRes of
+      case spanRes of
         Nothing -> return []
         Just budgetSpan -> do
           (intAllos, _) <- combineError intAlloRes acntRes (,)
-          let res1 = mapErrors (readIncome c intAllos budgetSpan) bgtIncomes
+          let res1 = mapErrors (readIncome c bgtLabel intAllos budgetSpan) bgtIncomes
-          let res2 = expandTransfers c budgetSpan bgtTransfers
+          let res2 = expandTransfers c bgtLabel budgetSpan bgtTransfers
           txs <- combineError (concat <$> res1) res2 (++)
           shadow <- addShadowTransfers bgtShadowTransfers txs
           return $ txs ++ shadow
@@ -54,7 +49,7 @@ readBudget
           ++ (alloAcnt <$> bgtTax)
           ++ (alloAcnt <$> bgtPosttax)
       getSpan = do
-        globalSpan <- asks (unBSpan . tsBudgetScope)
+        globalSpan <- asks (unBSpan . csBudgetScope)
         case bgtInterval of
           Nothing -> return $ Just globalSpan
           Just bi -> do
@@ -83,12 +78,14 @@ sortAllo a@Allocation {alloAmts = as} = do
 readIncome
   :: (MonadAppError m, MonadFinance m)
   => CommitR
+  -> BudgetName
   -> IntAllocations
   -> DaySpan
   -> Income
   -> m [Tx CommitR]
 readIncome
   key
+  name
   (intPre, intTax, intPost)
   ds
   Income
@@ -153,9 +150,13 @@ readIncome
                 }
         return $
           Tx
-            { txMeta = TxMeta day incPriority (TxDesc "") key
+            { txCommit = key
+            , txDate = day
             , txPrimary = Left primary
             , txOther = []
+            , txDescr = TxDesc ""
+            , txBudget = name
+            , txPriority = incPriority
             }
 
 periodScaler
@@ -354,10 +355,7 @@ fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch
     shaRes = liftExcept $ shadowMatches stMatch tx
 
 shadowMatches :: TransferMatcher -> Tx CommitR -> AppExcept Bool
-shadowMatches
+shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} Tx {txPrimary, txDate} = do
-  TransferMatcher {tmFrom, tmTo, tmDate, tmVal}
-  Tx {txPrimary, txMeta = TxMeta {txmDate}} =
-    do
   -- NOTE this will only match against the primary entry set since those
   -- are what are guaranteed to exist from a transfer
   valRes <- case txPrimary of
@@ -366,7 +364,7 @@ shadowMatches
   return $
     memberMaybe fa tmFrom
       && memberMaybe ta tmTo
-          && maybe True (`dateMatches` txmDate) tmDate
+      && maybe True (`dateMatches` txDate) tmDate
       && valRes
   where
     fa = either getAcntFrom getAcntFrom txPrimary

lib/Internal/Database.hs

@@ -1,11 +1,8 @@
-{-# LANGUAGE ImplicitPrelude #-}
-
 module Internal.Database
   ( runDB
-  , readDB
+  , readConfigState
   , nukeTables
-  , updateMeta
+  , updateDBState
-  -- , updateDBState
   , tree2Records
   , flattenAcntRoot
   , indexAcntRoot
@@ -13,14 +10,13 @@ module Internal.Database
   , mkPool
   , insertEntry
   , readUpdates
+  , insertAll
   , updateTx
-  , sync
   )
 where
 
 import Conduit
 import Control.Monad.Except
-import Control.Monad.IO.Rerunnable
 import Control.Monad.Logger
 import Data.Decimal
 import Data.Hashable
@@ -40,9 +36,7 @@ import Database.Persist.Sqlite hiding
   , (==.)
   , (||.)
   )
--- import GHC.Err
+import GHC.Err
-import Internal.Budget
-import Internal.History
 import Internal.Types.Main
 import Internal.Utils
 import RIO hiding (LogFunc, isNothing, on, (^.))
@@ -52,52 +46,6 @@ import qualified RIO.NonEmpty as NE
 import qualified RIO.Set as S
 import qualified RIO.Text as T
 
-sync
-  :: (MonadUnliftIO m, MonadRerunnableIO m)
-  => ConnectionPool
-  -> FilePath
-  -> Config
-  -> [Budget]
-  -> [History]
-  -> m ()
-sync pool root c bs hs = do
-  -- _ <- askLoggerIO
-
-  (meta, txState, budgets, history) <- runSqlQueryT pool $ do
-    runMigration migrateAll
-    liftIOExceptT $ readDB c bs hs
-
-  -- Read raw transactions according to state. If a transaction is already in
-  -- the database, don't read it but record the commit so we can update it.
-  (budgets', history') <-
-    flip runReaderT txState $ do
-      -- TODO collect errors here
-      b <- liftIOExceptT $ readBudgetCRUD budgets
-      h <- readHistoryCRUD root history
-      return (b, h)
-  -- liftIO $ print $ length $ coCreate budgets
-  liftIO $ print $ length $ fst $ coCreate history
-  liftIO $ print $ bimap length length $ coCreate history
-  liftIO $ print $ length $ coRead history
-  liftIO $ print $ length $ coUpdate history
-  liftIO $ print $ (\(DeleteTxs e a b c' d) -> (length e, length a, length b, length c', length d)) $ coDelete history
-  -- liftIO $ print $ length $ M.elems $ tsAccountMap txState
-  -- liftIO $ print $ length $ M.elems $ tsCurrencyMap txState
-  -- liftIO $ print $ length $ M.elems $ tsTagMap txState
-
-  -- Update the DB.
-  runSqlQueryT pool $ withTransaction $ flip runReaderT txState $ do
-    -- NOTE this must come first (unless we defer foreign keys)
-    updateMeta meta
-    res <- runExceptT $ do
-      -- TODO multithread this :)
-      insertBudgets budgets'
-      insertHistory history'
-    -- NOTE this rerunnable thing is a bit misleading; fromEither will throw
-    -- whatever error is encountered above in an IO context, but the first
-    -- thrown error should be caught despite possibly needing to be rerun
-    rerunnableIO $ fromEither res
-
 runDB
   :: MonadUnliftIO m
   => SqlConfig
@@ -158,116 +106,58 @@ nukeTables = do
 --     toFullPath path name = T.unwords [unValue @T.Text path, "/", unValue @T.Text name]
 --     toBal = maybe "???" (fmtRational 2) . unValue
 
-readDB
+readConfigState
   :: (MonadAppError m, MonadSqlQuery m)
   => Config
   -> [Budget]
   -> [History]
-  -> m (MetaCRUD, TxState, PreBudgetCRUD, PreHistoryCRUD)
+  -> m ConfigState
-readDB c bs hs = do
+readConfigState c bs hs = do
-  curAcnts <- readCurrentIds
+  (acnts2Ins, acntsRem, acnts2Del) <- diff newAcnts
-  curPaths <- readCurrentIds
+  (pathsIns, _, pathsDel) <- diff newPaths
-  curCurs <- readCurrentIds
+  (curs2Ins, cursRem, curs2Del) <- diff newCurs
-  curTags <- readCurrentIds
+  (tags2Ins, tagsRem, tags2Del) <- diff newTags
+  let amap = makeAcntMap $ acnts2Ins ++ (fst <$> acntsRem)
+  let cmap = currencyMap $ curs2Ins ++ (fst <$> cursRem)
+  let tmap = makeTagMap $ tags2Ins ++ (fst <$> tagsRem)
+  let fromMap f = S.fromList . fmap f . M.elems
+  let existing =
+        ExistingConfig (fromMap fst amap) (fromMap id tmap) (fromMap cpID cmap)
+
   (curBgts, curHistTrs, curHistSts) <- readCurrentCommits
+  -- TODO refine this test to include the whole db (with data already mixed
+  -- in this algorithm)
   let bsRes = BudgetSpan <$> resolveScope budgetInterval
   let hsRes = HistorySpan <$> resolveScope statementInterval
   combineErrorM bsRes hsRes $ \bscope hscope -> do
-    -- ASSUME the db must be empty if these are empty
+    let dbempty = null $ curBgts ++ curHistTrs ++ curHistSts
-    let dbempty = null curAcnts && null curCurs && null curTags
-    let meta =
-          MetaCRUD
-            { mcCurrencies = makeCD newCurs curCurs
-            , mcTags = makeCD newTags curTags
-            , mcAccounts = makeCD newAcnts curAcnts
-            , mcPaths = makeCD newPaths curPaths
-            , mcBudgetScope = bscope
-            , mcHistoryScope = hscope
-            }
-    let txS =
-          TxState
-            { tsAccountMap = amap
-            , tsCurrencyMap = cmap
-            , tsTagMap = tmap
-            , tsBudgetScope = bscope
-            , tsHistoryScope = hscope
-            }
     (bChanged, hChanged) <- readScopeChanged dbempty bscope hscope
-    budgets <- makeBudgetCRUD existing bs curBgts bChanged
+    bgt <- makeTxCRUD existing bs curBgts bChanged
-    history <- makeStatementCRUD existing (ts, curHistTrs) (ss, curHistSts) hChanged
+    hTrans <- makeTxCRUD existing ts curHistTrs hChanged
-    return (meta, txS, budgets, history)
+    hStmt <- makeTxCRUD existing ss curHistSts hChanged
+
+    return $
+      ConfigState
+        { csCurrencies = CRUDOps curs2Ins () () curs2Del
+        , csTags = CRUDOps tags2Ins () () tags2Del
+        , csAccounts = CRUDOps acnts2Ins () () acnts2Del
+        , csPaths = CRUDOps pathsIns () () pathsDel
+        , csBudgets = bgt
+        , csHistTrans = hTrans
+        , csHistStmts = hStmt
+        , csAccountMap = amap
+        , csCurrencyMap = cmap
+        , csTagMap = tmap
+        , csBudgetScope = bscope
+        , csHistoryScope = hscope
+        }
   where
     (ts, ss) = splitHistory hs
-    makeCD new old =
+    diff new = setDiffWith (\a b -> E.entityKey a == b) new <$> readCurrentIds
-      let (cs, _, ds) = setDiffWith (\a b -> E.entityKey a == b) new old
-       in CRUDOps cs () () ds
     (newAcnts, newPaths) = indexAcntRoot $ accounts c
     newTags = tag2Record <$> tags c
     newCurs = currency2Record <$> currencies c
     resolveScope f = liftExcept $ resolveDaySpan $ f $ scope c
-    amap = makeAcntMap newAcnts
-    cmap = currencyMap newCurs
-    tmap = makeTagMap newTags
-    fromMap f = S.fromList . fmap f . M.elems
-    existing = ExistingConfig (fromMap fst amap) (fromMap id tmap) (fromMap cpID cmap)
-
-makeBudgetCRUD
-  :: MonadSqlQuery m
-  => ExistingConfig
-  -> [Budget]
-  -> [CommitHash]
-  -> Bool
-  -> m (CRUDOps [Budget] () () DeleteTxs)
-makeBudgetCRUD existing new old scopeChanged = do
-  (toIns, toDel) <-
-    if scopeChanged
-      then (new,) <$> readTxIds old
-      else do
-        let (toDelHashes, overlap, toIns) = setDiffHashes old new
-        toDel <- readTxIds toDelHashes
-        (toInsRetry, _) <- readInvalidIds existing overlap
-        return (toIns ++ (snd <$> toInsRetry), toDel)
-  return $ CRUDOps toIns () () toDel
-
-makeStatementCRUD
-  :: (MonadAppError m, MonadSqlQuery m)
-  => ExistingConfig
-  -> ([PairedTransfer], [CommitHash])
-  -> ([Statement], [CommitHash])
-  -> Bool
-  -> m
-      ( CRUDOps
-          ([PairedTransfer], [Statement])
-          [ReadEntry]
-          [Either TotalUpdateEntrySet FullUpdateEntrySet]
-          DeleteTxs
-      )
-makeStatementCRUD existing ts ss scopeChanged = do
-  (toInsTs, toDelTs, validTs) <- uncurry diff ts
-  (toInsSs, toDelSs, validSs) <- uncurry diff ss
-  let toDelAllHashes = toDelTs ++ toDelSs
-  -- If we are inserting or deleting something or the scope changed, pull out
-  -- the remainder of the entries to update/read as we are (re)inserting other
-  -- stuff (this is necessary because a given transaction may depend on the
-  -- value of previous transactions, even if they are already in the DB).
-  (toRead, toUpdate) <- case (toInsTs, toInsSs, toDelAllHashes, scopeChanged) of
-    ([], [], [], False) -> return ([], [])
-    _ -> readUpdates $ validTs ++ validSs
-  toDelAll <- readTxIds toDelAllHashes
-  return $ CRUDOps (toInsTs, toInsSs) toRead toUpdate toDelAll
-  where
-    diff :: (MonadSqlQuery m, Hashable a) => [a] -> [CommitHash] -> m ([a], [CommitHash], [CommitHash])
-    diff new old = do
-      let (toDelHashes, overlap, toIns) = setDiffHashes old new
-      -- Check the overlap for rows with accounts/tags/currencies that
-      -- won't exist on the next update. Those with invalid IDs will be set aside
-      -- to delete and reinsert (which may also fail) later
-      (invalid, valid) <- readInvalidIds existing overlap
-      let (toDelAllHashes, toInsAll) = bimap (toDelHashes ++) (toIns ++) $ L.unzip invalid
-      return (toInsAll, toDelAllHashes, valid)
-
-setDiffHashes :: Hashable a => [CommitHash] -> [a] -> ([CommitHash], [(CommitHash, a)], [a])
-setDiffHashes = setDiffWith (\a b -> CommitHash (hash b) == a)
 
 readScopeChanged
   :: (MonadAppError m, MonadSqlQuery m)
@@ -285,6 +175,37 @@ readScopeChanged dbempty bscope hscope = do
       return (bscope /= b, hscope /= h)
     _ -> throwAppError $ DBError DBMultiScope
 
+makeTxCRUD
+  :: (MonadAppError m, MonadSqlQuery m, Hashable a)
+  => ExistingConfig
+  -> [a]
+  -> [CommitHash]
+  -> Bool
+  -> m
+      ( CRUDOps
+          [a]
+          [ReadEntry]
+          [Either TotalUpdateEntrySet FullUpdateEntrySet]
+          DeleteTxs
+      )
+makeTxCRUD existing newThings curThings scopeChanged = do
+  let (toDelHashes, overlap, toIns) =
+        setDiffWith (\a b -> hash b == unCommitHash a) curThings newThings
+  -- Check the overlap for rows with accounts/tags/currencies that
+  -- won't exist on the next update. Those with invalid IDs will be set aside
+  -- to delete and reinsert (which may also fail) later
+  (noRetry, toInsRetry) <- readInvalidIds existing overlap
+  let (toDelAllHashes, toInsAll) = bimap (toDelHashes ++) (toIns ++) $ L.unzip toInsRetry
+  -- If we are inserting or deleting something or the scope changed, pull out
+  -- the remainder of the entries to update/read as we are (re)inserting other
+  -- stuff (this is necessary because a given transaction may depend on the
+  -- value of previous transactions, even if they are already in the DB).
+  (toRead, toUpdate) <- case (toInsAll, toDelAllHashes, scopeChanged) of
+    ([], [], False) -> return ([], [])
+    _ -> readUpdates noRetry
+  toDelAll <- readTxIds toDelAllHashes
+  return $ CRUDOps toInsAll toRead toUpdate toDelAll
+
 readTxIds :: MonadSqlQuery m => [CommitHash] -> m DeleteTxs
 readTxIds cs = do
   xs <- selectE $ do
@@ -297,29 +218,33 @@ readTxIds cs = do
         `E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction)
           `E.innerJoin` E.table
         `E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset)
-          `E.leftJoin` E.table
+          `E.innerJoin` E.table
-        `E.on` (\(_ :& _ :& _ :& e :& t) -> E.just (e ^. EntryRId) ==. t ?. TagRelationREntry)
+        `E.on` (\(_ :& _ :& _ :& e :& t) -> e ^. EntryRId ==. t ^. TagRelationREntry)
     E.where_ $ commits ^. CommitRHash `E.in_` E.valList cs
     return
-      ( commits ^. CommitRId
+      ( txs ^. TransactionRId
-      , txs ^. TransactionRId
       , ess ^. EntrySetRId
       , es ^. EntryRId
-      , ts ?. TagRelationRId
+      , ts ^. TagRelationRId
       )
-  let (cms, txs, ss, es, ts) = L.unzip5 xs
+  let (txs, ss, es, ts) = L.unzip4 xs
   return $
     DeleteTxs
-      { dtCommits = go cms
+      { dtTxs = go txs
-      , dtTxs = go txs
       , dtEntrySets = go ss
       , dtEntries = go es
-      , dtTagRelations = catMaybes $ E.unValue <$> ts
+      , dtTagRelations = E.unValue <$> ts
       }
   where
     go :: Eq a => [E.Value a] -> [a]
     go = fmap (E.unValue . NE.head) . NE.group
 
+splitHistory :: [History] -> ([PairedTransfer], [Statement])
+splitHistory = partitionEithers . fmap go
+  where
+    go (HistTransfer x) = Left x
+    go (HistStatement x) = Right x
+
 makeTagMap :: [Entity TagR] -> TagMap
 makeTagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
 
@@ -330,7 +255,7 @@ currency2Record :: Currency -> Entity CurrencyR
 currency2Record c@Currency {curSymbol, curFullname, curPrecision} =
   Entity (toKey c) $ CurrencyR (CurID curSymbol) curFullname (fromIntegral curPrecision)
 
-readCurrentIds :: (PersistEntity a, MonadSqlQuery m) => m [Key a]
+readCurrentIds :: PersistEntity a => MonadSqlQuery m => m [Key a]
 readCurrentIds = fmap (E.unValue <$>) $ selectE $ do
   rs <- E.from E.table
   return (rs ^. E.persistIdField)
@@ -338,8 +263,8 @@ readCurrentIds = fmap (E.unValue <$>) $ selectE $ do
 readCurrentCommits :: MonadSqlQuery m => m ([CommitHash], [CommitHash], [CommitHash])
 readCurrentCommits = do
   xs <- selectE $ do
-    commits <- E.from E.table
+    rs <- E.from E.table
-    return (commits ^. CommitRHash, commits ^. CommitRType)
+    return (rs ^. CommitRHash, rs ^. CommitRType)
   return $ foldr go ([], [], []) xs
   where
     go (x, t) (bs, ts, hs) =
@@ -462,55 +387,39 @@ indexAcntRoot = bimap concat concat . L.unzip . fmap (uncurry tree2Records) . fl
 updateCD
   :: ( MonadSqlQuery m
      , PersistRecordBackend a SqlBackend
+     , PersistRecordBackend b SqlBackend
      )
-  => EntityCRUDOps a
+  => CDOps (Entity a) (Key b)
   -> m ()
 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
+deleteTxs DeleteTxs {dtTxs, dtEntrySets, dtEntries, dtTagRelations} = do
-  mapM_ deleteKeyE dtTagRelations
-  mapM_ deleteKeyE dtEntries
-  mapM_ deleteKeyE dtEntrySets
   mapM_ deleteKeyE dtTxs
-  mapM_ deleteKeyE dtCommits
+  mapM_ deleteKeyE dtEntrySets
+  mapM_ deleteKeyE dtEntries
+  mapM_ deleteKeyE dtTagRelations
 
--- updateDBState :: (MonadFinance m, MonadSqlQuery m) => m ()
+updateDBState :: (MonadFinance m, MonadSqlQuery m) => m ()
--- updateDBState = do
+updateDBState = do
---   updateCD =<< asks csCurrencies
+  updateCD =<< asks csCurrencies
---   updateCD =<< asks csAccounts
+  updateCD =<< asks csAccounts
---   updateCD =<< asks csPaths
+  updateCD =<< asks csPaths
---   updateCD =<< asks csTags
+  updateCD =<< asks csTags
---   -- deleteTxs =<< asks (coDelete . csBudgets)
+  deleteTxs =<< asks (coDelete . csBudgets)
---   -- deleteTxs =<< asks (coDelete . csHistory)
+  deleteTxs =<< asks (coDelete . csHistTrans)
---   b <- asks csBudgetScope
+  deleteTxs =<< asks (coDelete . csHistStmts)
---   h <- asks csHistoryScope
+  b <- asks csBudgetScope
---   repsertE (E.toSqlKey 1) $ ConfigStateR h b
+  h <- asks csHistoryScope
-
+  repsertE (E.toSqlKey 1) $ ConfigStateR h b
-updateMeta :: MonadSqlQuery m => MetaCRUD -> m ()
-updateMeta
-  MetaCRUD
-    { mcCurrencies
-    , mcAccounts
-    , mcPaths
-    , mcTags
-    , mcBudgetScope
-    , mcHistoryScope
-    } = do
-    updateCD mcCurrencies
-    updateCD mcAccounts
-    updateCD mcPaths
-    updateCD mcTags
-    repsertE (E.toSqlKey 1) $ ConfigStateR mcHistoryScope mcBudgetScope
 
 readInvalidIds
   :: MonadSqlQuery m
   => ExistingConfig
   -> [(CommitHash, a)]
-  -> m ([(CommitHash, a)], [CommitHash])
+  -> m ([CommitHash], [(CommitHash, a)])
 readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
   rs <- selectE $ do
     (commits :& _ :& entrysets :& entries :& tags) <-
@@ -535,13 +444,14 @@ readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
   let cs = go ecCurrencies $ fmap (\(i, E.Value c, _, _) -> (i, c)) rs
   let as = go ecAccounts $ fmap (\(i, _, E.Value a, _) -> (i, a)) rs
   let ts = go ecTags [(i, t) | (i, _, _, E.Value (Just t)) <- rs]
-  let invalid = (cs `S.union` as) `S.union` ts
+  let valid = (cs `S.intersection` as) `S.intersection` ts
-  return $ second (fst <$>) $ L.partition ((`S.member` invalid) . fst) xs
+  let (a0, _) = first (fst <$>) $ L.partition ((`S.member` valid) . fst) xs
+  return (a0, [])
   where
     go existing =
       S.fromList
         . fmap (E.unValue . fst)
-        . L.filter (not . all (`S.member` existing) . snd)
+        . L.filter (all (`S.member` existing) . snd)
         . groupKey id
 
 readUpdates
@@ -567,10 +477,9 @@ readUpdates hashes = do
       ,
         (
           ( entrysets ^. EntrySetRId
-          , entrysets ^. EntrySetRIndex
           , txs ^. TransactionRDate
+          , txs ^. TransactionRBudgetName
           , txs ^. TransactionRPriority
-          , txs ^. TransactionRDescription
           ,
             ( entrysets ^. EntrySetRCurrency
             , currencies ^. CurrencyRPrecision
@@ -580,12 +489,11 @@ 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 ((_, esi, day, pri, desc, (curID, prec)), es) = do
+    makeUES ((_, day, name, pri, (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 =
@@ -603,7 +511,8 @@ readUpdates hashes = do
             Left x ->
               Left $
                 UpdateEntrySet
-                  { utCurrency = cur
+                  { utDate = E.unValue day
+                  , utCurrency = cur
                   , utFrom0 = x
                   , utTo0 = to0
                   , utFromRO = fromRO
@@ -611,13 +520,14 @@ readUpdates hashes = do
                   , utFromUnk = fromUnk
                   , utToUnk = toUnk
                   , utTotalValue = realFracToDecimalP prec' tot
-                  , utSortKey = sk
+                  , utBudget = E.unValue name
-                  , utIndex = E.unValue esi
+                  , utPriority = E.unValue pri
                   }
             Right x ->
               Right $
                 UpdateEntrySet
-                  { utCurrency = cur
+                  { utDate = E.unValue day
+                  , utCurrency = cur
                   , utFrom0 = x
                   , utTo0 = to0
                   , utFromRO = fromRO
@@ -625,20 +535,20 @@ readUpdates hashes = do
                   , utFromUnk = fromUnk
                   , utToUnk = toUnk
                   , utTotalValue = ()
-                  , utSortKey = sk
+                  , utBudget = E.unValue name
-                  , utIndex = E.unValue esi
+                  , utPriority = E.unValue pri
                   }
         -- TODO this error is lame
-        _ -> throwAppError $ DBError DBUpdateUnbalanced
+        _ -> throwAppError $ DBError $ DBUpdateUnbalanced
-    makeRE ((_, esi, day, pri, desc, (curID, prec)), entry) = do
+    makeRE ((_, day, name, pri, (curID, prec)), entry) = do
       let e = entityVal entry
        in ReadEntry
-            { reCurrency = E.unValue curID
+            { reDate = E.unValue day
+            , reCurrency = E.unValue curID
             , reAcnt = entryRAccount e
             , reValue = realFracToDecimal (fromIntegral $ E.unValue prec) (entryRValue e)
-            , reSortKey = TxSortKey (E.unValue day) (E.unValue pri) (E.unValue desc)
+            , reBudget = E.unValue name
-            , reESIndex = E.unValue esi
+            , rePriority = E.unValue pri
-            , reIndex = entryRIndex e
             }
 
 splitFrom
@@ -755,8 +665,8 @@ readDeferredValue prec (k, e) = case (entryRCachedValue e, entryRCachedType e) o
   (Nothing, Nothing) -> return $ Left $ makeUnkUE k e
   (Just v, Nothing) -> err $ DBLinkInvalidValue v False
   (Just v, Just TFixed) -> err $ DBLinkInvalidValue v True
-  (Nothing, Just TBalance) -> err DBLinkInvalidBalance
+  (Nothing, Just TBalance) -> err $ DBLinkInvalidBalance
-  (Nothing, Just TPercent) -> err DBLinkInvalidPercent
+  (Nothing, Just TPercent) -> err $ DBLinkInvalidPercent
   where
     go = return . Right . Right
     err = throwAppError . DBError . DBLinkError k
@@ -770,72 +680,21 @@ makeRoUE prec e = makeUE () e $ StaticValue (realFracToDecimalP prec $ entryRVal
 makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId ()
 makeUnkUE k e = makeUE k e ()
 
--- updateEntries
+insertAll
---   :: (MonadSqlQuery m, MonadFinance m, MonadRerunnableIO m)
---   => [ ( BudgetName
---        , CRUDOps
---           [Tx CommitR]
---           [ReadEntry]
---           [(Either TotalUpdateEntrySet FullUpdateEntrySet)]
---           DeleteTxs
---        )
---      ]
---   -> m ()
--- updateEntries es = do
---   res <- runExceptT $ mapErrors (uncurry insertAll) es
---   void $ rerunnableIO $ fromEither res
-
-insertBudgets
   :: (MonadAppError m, MonadSqlQuery m, MonadFinance m)
-  => FinalBudgetCRUD
+  => [EntryCRU]
   -> m ()
-insertBudgets (CRUDOps bs () () ds) = do
+insertAll ebs = do
-  deleteTxs ds
+  (toUpdate, toInsert) <- balanceTxs ebs
-  mapM_ go bs
-  where
-    go (name, cs) = do
-      -- TODO useless overhead?
-      (toUpdate, toInsert) <- balanceTxs (ToInsert <$> cs)
   mapM_ updateTx toUpdate
-      forM_ (groupWith (txmCommit . itxMeta) toInsert) $
+  forM_ (groupWith itxCommit toInsert) $
     \(c, ts) -> do
       ck <- insert c
-          mapM_ (insertTx name ck) ts
+      mapM_ (insertTx ck) ts
 
-insertHistory
+insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m ()
-  :: (MonadAppError m, MonadSqlQuery m, MonadFinance m)
+insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxBudget, itxPriority} = do
-  => FinalHistoryCRUD
+  k <- insert $ TransactionR c itxDate itxDescr itxBudget itxPriority
-  -> m ()
-insertHistory (CRUDOps cs rs us ds) = do
-  (toUpdate, toInsert) <- balanceTxs $ (ToInsert <$> cs) ++ (ToRead <$> rs) ++ (ToUpdate <$> us)
-  mapM_ updateTx toUpdate
-  forM_ (groupWith (txmCommit . itxMeta) toInsert) $
-    \(c, ts) -> do
-      ck <- insert c
-      mapM_ (insertTx historyName ck) ts
-  deleteTxs ds
-
--- insertAll
---   :: (MonadAppError m, MonadSqlQuery m, MonadFinance m)
---   => BudgetName
---   -> CRUDOps
---       [Tx CommitR]
---       [ReadEntry]
---       [Either TotalUpdateEntrySet FullUpdateEntrySet]
---       DeleteTxs
---   -> m ()
--- insertAll b (CRUDOps cs rs us ds) = do
---   (toUpdate, toInsert) <- balanceTxs $ (ToInsert <$> cs) ++ (ToRead <$> rs) ++ (ToUpdate <$> us)
---   mapM_ updateTx toUpdate
---   forM_ (groupWith itxCommit toInsert) $
---     \(c, ts) -> do
---       ck <- insert c
---       mapM_ (insertTx b ck) ts
---   deleteTxs ds
-
-insertTx :: MonadSqlQuery m => BudgetName -> CommitRId -> InsertTx -> m ()
-insertTx b c InsertTx {itxMeta = TxMeta {txmDate, txmPriority, txmDesc}, itxEntrySets} = do
-  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
@@ -881,6 +740,3 @@ deleteKeyE q = unsafeLiftSql "esqueleto-deleteKey" (E.deleteKey q)
 
 insertEntityManyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => [Entity a] -> m ()
 insertEntityManyE q = unsafeLiftSql "esqueleto-insertEntityMany" (E.insertEntityMany q)
-
-historyName :: BudgetName
-historyName = BudgetName "history"

lib/Internal/History.hs

@@ -2,7 +2,6 @@ module Internal.History
   ( readHistStmt
   , readHistTransfer
   , splitHistory
-  , readHistoryCRUD
   )
 where
 
@@ -25,20 +24,6 @@ import qualified RIO.Vector as V
 import Text.Regex.TDFA hiding (matchAll)
 import Text.Regex.TDFA.Text
 
-readHistoryCRUD
-  :: (MonadUnliftIO m, MonadFinance m)
-  => FilePath
-  -> PreHistoryCRUD
-  -> m FinalHistoryCRUD
-readHistoryCRUD root o@CRUDOps {coCreate = (ts, ss)} = do
-  -- TODO multithread this for some extra fun :)
-
-  ss' <- mapM (readHistStmt root) ss
-  fromEitherM $ runExceptT $ do
-    let sRes = mapErrors (ExceptT . return) ss'
-    let tRes = mapErrors readHistTransfer ts
-    combineError sRes tRes $ \ss'' ts' -> o {coCreate = concat ss'' ++ concat ts'}
-
 -- NOTE keep statement and transfer readers separate because the former needs
 -- the IO monad, and thus will throw IO errors rather than using the ExceptT
 -- thingy
@@ -56,8 +41,8 @@ readHistTransfer
   => PairedTransfer
   -> m [Tx CommitR]
 readHistTransfer ht = do
-  bounds <- asks (unHSpan . tsHistoryScope)
+  bounds <- asks (unHSpan . csHistoryScope)
-  expandTransfer c bounds ht
+  expandTransfer c historyName bounds ht
   where
     c = CommitR (CommitHash $ hash ht) CTHistoryTransfer
 
@@ -68,28 +53,23 @@ readHistStmt
   :: (MonadUnliftIO m, MonadFinance m)
   => FilePath
   -> Statement
-  -> m (Either AppException [Tx CommitR])
+  -> m [Tx CommitR]
 readHistStmt root i = do
-  bounds <- asks (unHSpan . tsHistoryScope)
   bs <- readImport root i
-  return $ filter (inDaySpan bounds . txmDate . txMeta) . fmap go <$> bs
+  bounds <- asks (unHSpan . csHistoryScope)
+  return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs
   where
-    go t@Tx {txMeta = m} =
+    c = CommitR (CommitHash $ hash i) CTHistoryStatement
-      t {txMeta = m {txmCommit = CommitR (CommitHash $ hash i) CTHistoryStatement}}
 
 -- TODO this probably won't scale well (pipes?)
-readImport
+readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [Tx ()]
-  :: (MonadUnliftIO m, MonadFinance m)
-  => FilePath
-  -> Statement
-  -> m (Either AppException [Tx ()])
 readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
   let ores = compileOptions stmtTxOpts
   let cres = combineErrors $ compileMatch <$> stmtParsers
   (compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,)
   let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions
   records <- L.sort . concat <$> mapErrorsIO readStmt paths
-  runExceptT (matchRecords compiledMatches records)
+  fromEither =<< runExceptT (matchRecords compiledMatches records)
   where
     paths = (root </>) <$> stmtPaths
 
@@ -320,7 +300,9 @@ toTx
   r@TxRecord {trAmount, trDate, trDesc} = do
     combineError curRes subRes $ \(cur, f, t) ss ->
       Tx
-        { txMeta = TxMeta trDate priority trDesc ()
+        { txDate = trDate
+        , txDescr = trDesc
+        , txCommit = ()
         , txPrimary =
             Left $
               EntrySet
@@ -330,10 +312,12 @@ toTx
                 , esTo = t
                 }
         , txOther = Left <$> ss
+        , txBudget = historyName
+        , txPriority = priority
         }
     where
       curRes = do
-        m <- asks tsCurrencyMap
+        m <- asks csCurrencyMap
         cur <- liftInner $ resolveCurrency m r tgCurrency
         let prec = cpPrec cur
         let fromRes = liftInner $ resolveHalfEntry resolveFromValue prec r () tgFrom
@@ -347,7 +331,7 @@ resolveSubGetter
   -> TxSubGetter
   -> AppExceptT m SecondayEntrySet
 resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
-  m <- asks tsCurrencyMap
+  m <- asks csCurrencyMap
   cur <- liftInner $ resolveCurrency m r tsgCurrency
   let prec = cpPrec cur
   let toRes = resolveHalfEntry resolveToValue prec r () tsgTo
@@ -526,3 +510,6 @@ parseDecimal (pat, re) s = case matchGroupsMaybe s re of
       w <- readT "whole number" x
       k <- readSign sign
       return (k, w)
+
+historyName :: BudgetName
+historyName = BudgetName "history"

lib/Internal/Types/Database.hs

@@ -24,12 +24,10 @@ 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
@@ -37,14 +35,12 @@ 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
@@ -53,28 +49,24 @@ 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
-    budgetName BudgetName
     description TxDesc
+    budgetName BudgetName
     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 
@@ -85,16 +77,12 @@ 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

@@ -26,51 +26,32 @@ import Text.Regex.TDFA
 --------------------------------------------------------------------------------
 -- database cache types
 
-type MonadFinance = MonadReader TxState
+type MonadFinance = MonadReader ConfigState
 
 data DeleteTxs = DeleteTxs
-  { dtCommits :: ![CommitRId]
+  { dtTxs :: ![TransactionRId]
-  , dtTxs :: ![TransactionRId]
   , dtEntrySets :: ![EntrySetRId]
   , dtEntries :: ![EntryRId]
   , dtTagRelations :: ![TagRelationRId]
   }
   deriving (Show)
 
-type EntityCRUDOps r = CRUDOps [Entity r] () () [Key r]
+type CDOps c d = CRUDOps [c] () () [d]
 
-data MetaCRUD = MetaCRUD
+-- TODO split the entry stuff from the account metadata stuff
-  { mcCurrencies :: !(EntityCRUDOps CurrencyR)
+data ConfigState = ConfigState
-  , mcAccounts :: !(EntityCRUDOps AccountR)
+  { csCurrencies :: !(CDOps (Entity CurrencyR) CurrencyRId)
-  , mcPaths :: !(EntityCRUDOps AccountPathR)
+  , csAccounts :: !(CDOps (Entity AccountR) AccountRId)
-  , mcTags :: !(EntityCRUDOps TagR)
+  , csPaths :: !(CDOps (Entity AccountPathR) AccountPathRId)
-  , mcBudgetScope :: !BudgetSpan
+  , csTags :: !(CDOps (Entity TagR) TagRId)
-  , mcHistoryScope :: !HistorySpan
+  , csBudgets :: !(CRUDOps [Budget] [ReadEntry] [Either TotalUpdateEntrySet FullUpdateEntrySet] DeleteTxs)
-  }
+  , csHistTrans :: !(CRUDOps [PairedTransfer] [ReadEntry] [Either TotalUpdateEntrySet FullUpdateEntrySet] DeleteTxs)
-
+  , csHistStmts :: !(CRUDOps [Statement] [ReadEntry] [Either TotalUpdateEntrySet FullUpdateEntrySet] DeleteTxs)
-type BudgetCRUDOps b = CRUDOps [b] () () DeleteTxs
+  , csAccountMap :: !AccountMap
-
+  , csCurrencyMap :: !CurrencyMap
-type PreBudgetCRUD = BudgetCRUDOps Budget
+  , csTagMap :: !TagMap
-
+  , csBudgetScope :: !BudgetSpan
-type FinalBudgetCRUD = BudgetCRUDOps (BudgetName, [Tx CommitR])
+  , csHistoryScope :: !HistorySpan
-
-type HistoryCRUDOps h =
-  CRUDOps
-    h
-    [ReadEntry]
-    [Either TotalUpdateEntrySet FullUpdateEntrySet]
-    DeleteTxs
-
-type PreHistoryCRUD = HistoryCRUDOps ([PairedTransfer], [Statement])
-
-type FinalHistoryCRUD = HistoryCRUDOps [Tx CommitR]
-
-data TxState = TxState
-  { tsAccountMap :: !AccountMap
-  , tsCurrencyMap :: !CurrencyMap
-  , tsTagMap :: !TagMap
-  , tsBudgetScope :: !BudgetSpan
-  , tsHistoryScope :: !HistorySpan
   }
   deriving (Show)
 
@@ -102,22 +83,13 @@ 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
-  , reIndex :: !EntryIndex
+  , reDate :: !Day
-  , reESIndex :: !EntrySetIndex
+  , rePriority :: !Int
-  , reSortKey :: !TxSortKey
+  , reBudget :: !BudgetName
   }
   deriving (Show)
 
@@ -157,9 +129,10 @@ data UpdateEntrySet f t = UpdateEntrySet
   , utFromRO :: ![UE_RO]
   , utToRO :: ![UE_RO]
   , utCurrency :: !CurrencyRId
+  , utDate :: !Day
   , utTotalValue :: !t
-  , utIndex :: !EntrySetIndex
+  , utBudget :: !BudgetName
-  , utSortKey :: !TxSortKey
+  , utPriority :: !Int
   }
   deriving (Show)
 
@@ -222,18 +195,14 @@ 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
-  { txMeta :: !(TxMeta k)
+  { txDescr :: !TxDesc
+  , txDate :: !Day
+  , txPriority :: !Int
   , txPrimary :: !(Either PrimaryEntrySet TransferEntrySet)
   , txOther :: ![Either SecondayEntrySet ShadowEntrySet]
+  , txCommit :: !k
+  , txBudget :: !BudgetName
   }
   deriving (Generic, Show)
 
@@ -249,8 +218,12 @@ data InsertEntrySet = InsertEntrySet
   }
 
 data InsertTx = InsertTx
-  { itxMeta :: !(TxMeta CommitR)
+  { itxDescr :: !TxDesc
+  , itxDate :: !Day
+  , itxPriority :: !Int
   , itxEntrySets :: !(NonEmpty InsertEntrySet)
+  , itxCommit :: !CommitR
+  , itxBudget :: !BudgetName
   }
   deriving (Generic)
 

lib/Internal/Utils.hs

@@ -151,7 +151,7 @@ askDays
   -> Maybe Interval
   -> m [Day]
 askDays dp i = do
-  globalSpan <- asks (unBSpan . tsBudgetScope)
+  globalSpan <- asks (unBSpan . csBudgetScope)
   case i of
     Just i' -> do
       localSpan <- liftExcept $ resolveDaySpan i'
@@ -599,7 +599,7 @@ uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
 uncurry3 f (a, b, c) = f a b c
 
 lookupAccount :: (MonadAppError m, MonadFinance m) => AcntID -> m (AccountRId, AcntType)
-lookupAccount = lookupFinance AcntField tsAccountMap
+lookupAccount = lookupFinance AcntField csAccountMap
 
 lookupAccountKey :: (MonadAppError m, MonadFinance m) => AcntID -> m AccountRId
 lookupAccountKey = fmap fst . lookupAccount
@@ -608,7 +608,7 @@ lookupAccountType :: (MonadAppError m, MonadFinance m) => AcntID -> m AcntType
 lookupAccountType = fmap snd . lookupAccount
 
 lookupCurrency :: (MonadAppError m, MonadFinance m) => CurID -> m CurrencyPrec
-lookupCurrency = lookupFinance CurField tsCurrencyMap
+lookupCurrency = lookupFinance CurField csCurrencyMap
 
 lookupCurrencyKey :: (MonadAppError m, MonadFinance m) => CurID -> m CurrencyRId
 lookupCurrencyKey = fmap cpID . lookupCurrency
@@ -617,12 +617,12 @@ lookupCurrencyPrec :: (MonadAppError m, MonadFinance m) => CurID -> m Precision
 lookupCurrencyPrec = fmap cpPrec . lookupCurrency
 
 lookupTag :: (MonadAppError m, MonadFinance m) => TagID -> m TagRId
-lookupTag = lookupFinance TagField tsTagMap
+lookupTag = lookupFinance TagField csTagMap
 
 lookupFinance
   :: (MonadAppError m, MonadFinance m, Ord k, Show k)
   => EntryIDType
-  -> (TxState -> M.Map k a)
+  -> (ConfigState -> M.Map k a)
   -> k
   -> m a
 lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< asks f
@@ -639,38 +639,39 @@ balanceTxs ebs =
       fmap (Just . Left) $
         liftInnerS $
           either rebalanceTotalEntrySet rebalanceFullEntrySet utx
-    go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do
+    go (ToRead ReadEntry {reCurrency, reAcnt, reValue, reBudget}) = do
-      modify $ mapAdd_ (reAcnt, reCurrency) reValue
+      modify $ mapAdd_ (reAcnt, (reCurrency, reBudget)) reValue
       return Nothing
-    go (ToInsert Tx {txPrimary, txOther, txMeta}) = do
+    go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate, txBudget, txPriority}) = do
-      e <- either balancePrimaryEntrySet balanceSecondaryEntrySet txPrimary
+      e <- either (balancePrimaryEntrySet txBudget) (balanceSecondaryEntrySet txBudget) txPrimary
       let tot = sum $ fmap (eValue . ieEntry) $ NE.toList $ iesFromEntries e
       es <- mapErrors (goOther tot) txOther
-      let tx = InsertTx {itxMeta = txMeta, itxEntrySets = e :| es}
+      let tx =
+            -- TODO this is lame
+            InsertTx
+              { itxDescr = txDescr
+              , itxDate = txDate
+              , itxEntrySets = e :| es
+              , itxCommit = txCommit
+              , itxBudget = txBudget
+              , itxPriority = txPriority
+              }
       return $ Just $ Right tx
       where
         goOther tot =
           either
-            balanceSecondaryEntrySet
+            (balanceSecondaryEntrySet txBudget)
-            (balancePrimaryEntrySet . fromShadow tot)
+            (balancePrimaryEntrySet txBudget . fromShadow tot)
         fromShadow tot e@EntrySet {esTotalValue} = e {esTotalValue = tot *. esTotalValue}
 
--- NOTE this sorting thing is super wonky; I'm basically sorting three different
+binDate :: EntryCRU -> (Day, Int)
--- levels of the hierarchy directory and assuming there will be no overlaps.
+binDate (ToRead ReadEntry {reDate, rePriority}) = (reDate, rePriority)
--- First, sort at the transaction level by day, priority, and description as
+binDate (ToInsert Tx {txDate, txPriority}) = (txDate, txPriority)
--- 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 {utSortKey, utIndex} = (utSortKey, Just utIndex, Nothing)
+    go UpdateEntrySet {utDate, utPriority} = (utDate, utPriority)
 
-type BCKey = CurrencyRId
+type BCKey = (CurrencyRId, BudgetName)
 
 type ABCKey = (AccountRId, BCKey)
 
@@ -691,6 +692,7 @@ rebalanceTotalEntrySet
     , utToRO
     , utCurrency
     , utTotalValue
+    , utBudget
     } =
     do
       (fval, fs, tpairs) <- rebalanceDebit bc utFromRO utFromUnk
@@ -700,7 +702,7 @@ rebalanceTotalEntrySet
       ts <- rebalanceCredit bc utTotalValue utTo0 utToUnk utToRO tsLinked
       return (f0 {ueValue = StaticValue f0val} : fs ++ ts)
     where
-      bc = utCurrency
+      bc = (utCurrency, utBudget)
 
 rebalanceFullEntrySet :: FullUpdateEntrySet -> State EntryBals [UEBalanced]
 rebalanceFullEntrySet
@@ -712,6 +714,7 @@ rebalanceFullEntrySet
     , utFromRO
     , utToRO
     , utCurrency
+    , utBudget
     } =
     do
       (ftot, fs, tpairs) <- rebalanceDebit bc rs ls
@@ -721,7 +724,7 @@ rebalanceFullEntrySet
       (rs, ls) = case utFrom0 of
         Left x -> (x : utFromRO, utFromUnk)
         Right x -> (utFromRO, x : utFromUnk)
-      bc = utCurrency
+      bc = (utCurrency, utBudget)
 
 rebalanceDebit
   :: BCKey
@@ -803,9 +806,11 @@ updateUnknown k e = do
 
 balancePrimaryEntrySet
   :: (MonadAppError m, MonadFinance m)
-  => PrimaryEntrySet
+  => BudgetName
+  -> PrimaryEntrySet
   -> StateT EntryBals m InsertEntrySet
 balancePrimaryEntrySet
+  budgetName
   EntrySet
     { esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
     , esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
@@ -817,7 +822,7 @@ balancePrimaryEntrySet
       let t0res = resolveAcntAndTags t0
       let fsres = mapErrors resolveAcntAndTags fs
       let tsres = mapErrors resolveAcntAndTags ts
-      let bc = esCurrency
+      let bc = (esCurrency, budgetName)
       combineErrorM (combineError f0res fsres (,)) (combineError t0res tsres (,)) $
         \(f0', fs') (t0', ts') -> do
           let balFrom = fmap liftInnerS . balanceDeferred
@@ -826,9 +831,11 @@ balancePrimaryEntrySet
 
 balanceSecondaryEntrySet
   :: (MonadAppError m, MonadFinance m)
-  => SecondayEntrySet
+  => BudgetName
+  -> SecondayEntrySet
   -> StateT EntryBals m InsertEntrySet
 balanceSecondaryEntrySet
+  budgetName
   EntrySet
     { esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
     , esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
@@ -845,7 +852,7 @@ balanceSecondaryEntrySet
     where
       entrySum = sum . fmap (eValue . ieEntry)
       balFrom = balanceEntry (fmap liftInnerS . balanceDeferred) bc
-      bc = esCurrency
+      bc = (esCurrency, budgetName)
 
 balanceFinal
   :: (MonadAppError m)
@@ -855,10 +862,10 @@ balanceFinal
   -> Entry AccountRId () TagRId
   -> [Entry AccountRId EntryLink TagRId]
   -> StateT EntryBals m InsertEntrySet
-balanceFinal curID tot fs t0 ts = do
+balanceFinal k@(curID, _) tot fs t0 ts = do
   let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs
   let balTo = balanceLinked fv
-  ts' <- balanceTotalEntrySet balTo curID tot t0 ts
+  ts' <- balanceTotalEntrySet balTo k tot t0 ts
   return $
     InsertEntrySet
       { iesCurrency = curID
@@ -956,18 +963,20 @@ findBalance k e = do
 expandTransfers
   :: (MonadAppError m, MonadFinance m)
   => CommitR
+  -> BudgetName
   -> DaySpan
   -> [PairedTransfer]
   -> m [Tx CommitR]
-expandTransfers tc bounds = fmap concat . mapErrors (expandTransfer tc bounds)
+expandTransfers tc name bounds = fmap concat . mapErrors (expandTransfer tc name bounds)
 
 expandTransfer
   :: (MonadAppError m, MonadFinance m)
   => CommitR
+  -> BudgetName
   -> DaySpan
   -> PairedTransfer
   -> m [Tx CommitR]
-expandTransfer tc bounds Transfer {transAmounts, transTo, transCurrency, transFrom} = do
+expandTransfer tc name bounds Transfer {transAmounts, transTo, transCurrency, transFrom} = do
   txs <- mapErrors go transAmounts
   return $ concat txs
   where
@@ -988,9 +997,13 @@ expandTransfer tc bounds Transfer {transAmounts, transTo, transCurrency, transFr
         withDates bounds pat $ \day ->
           return
             Tx
-              { txMeta = TxMeta day (fromIntegral pri) (TxDesc desc) tc
+              { txCommit = tc
+              , txDate = day
               , txPrimary = Right $ entryPair transFrom transTo (cpID cp) desc () v''
               , txOther = []
+              , txDescr = TxDesc desc
+              , txBudget = name
+              , txPriority = fromIntegral pri
               }
 
 entryPair