WIP balance transactions in two different ways

app/Main.hs

@@ -180,10 +180,13 @@ runSync c = do
         hSs' <- mapErrorsIO (readHistStmt root) hSs
         hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs
         bTs <- liftIOExceptT $ mapErrors readBudget $ budget config
+        -- lift $ print hTs'
         return $ second concat $ partitionEithers $ hSs' ++ hTs' ++ bTs
 
     -- Update the DB.
     runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
+      -- NOTE this must come first (unless we defer foreign keys)
+      updateDBState updates
       res <- runExceptT $ do
         -- TODO taking out the hash is dumb
         (rs, ues) <- readUpdates $ fmap commitRHash rus
@@ -193,7 +196,6 @@ runSync c = do
       -- 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
-      updateDBState updates -- TODO this will only work if foreign keys are deferred
   where
     root = takeDirectory c
     err (InsertException es) = do

lib/Internal/Budget.hs

@@ -143,12 +143,14 @@ readIncome
             incCurrency
             "balance after deductions"
             (fromRational balance)
+            ()
+        -- TODO make this into one large tx?
         allos <- mapErrors (allo2Trans tc day incFrom) (pre ++ tax ++ post)
         let bal =
               Tx
                 { txCommit = tc
                 , txDate = day
-                , txPrimary = primary
+                , txPrimary = Left primary
                 , txOther = []
                 , txDescr = "balance after deductions"
                 }
@@ -264,12 +266,12 @@ allo2Trans
   -> m (Tx TxCommit)
 allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} = do
   -- TODO double here?
-  p <- entryPair from faTo faCur faDesc (fromRational faValue)
+  p <- entryPair from faTo faCur faDesc (fromRational faValue) ()
   return
     Tx
       { txCommit = meta
       , txDate = day
-      , txPrimary = p
+      , txPrimary = Left p
       , txOther = []
       , txDescr = faDesc
       }
@@ -355,30 +357,36 @@ addShadowTransfers ms = mapErrors go
   where
     go tx = do
       es <- catMaybes <$> mapErrors (fromShadow tx) ms
-      return $ tx {txOther = es}
+      return $ tx {txOther = Right <$> es}
 
 fromShadow
   :: (MonadInsertError m, MonadFinance m)
   => Tx TxCommit
   -> ShadowTransfer
-  -> m (Maybe (EntrySet AcntID CurrencyPrec TagID Rational (Either Double (EntryValue Rational))))
+  -> m (Maybe ShadowEntrySet)
 fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} = do
   res <- liftExcept $ shadowMatches stMatch tx
-  es <- entryPair_ (\_ v -> Left v) stFrom stTo stCurrency stDesc stRatio
+  es <- entryPair stFrom stTo stCurrency stDesc stRatio ()
   return $ if not res then Nothing else Just es
 
 shadowMatches :: TransferMatcher -> Tx TxCommit -> InsertExcept Bool
-shadowMatches TransferMatcher {tmFrom, tmTo, tmDate} Tx {txPrimary, txDate} = do
+shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} Tx {txPrimary, txDate} = do
   -- NOTE this will only match against the primary entry set since those
   -- are what are guaranteed to exist from a transfer
-  -- valRes <- valMatches tmVal $ esTotalValue $ txPrimary
+  valRes <- case txPrimary of
+    Left es -> valMatches tmVal $ esTotalValue es
+    Right _ -> return True
   return $
-    memberMaybe (eAcnt $ hesPrimary $ esFrom txPrimary) tmFrom
+    memberMaybe fa tmFrom
-      && memberMaybe (eAcnt $ hesPrimary $ esTo txPrimary) tmTo
+      && memberMaybe ta tmTo
       && maybe True (`dateMatches` txDate) tmDate
+      && valRes
   where
-    -- && valRes
+    fa = either getAcntFrom getAcntFrom txPrimary
-
+    ta = either getAcntTo getAcntTo txPrimary
+    getAcntFrom = getAcnt esFrom
+    getAcntTo = getAcnt esTo
+    getAcnt f = eAcnt . hesPrimary . f
     memberMaybe x AcntSet {asList, asInclude} =
       (if asInclude then id else not) $ x `elem` asList
 

lib/Internal/Database.hs

@@ -13,7 +13,6 @@ module Internal.Database
   , whenHash_
   , eitherHash
   , insertEntry
-  , resolveEntry
   , readUpdates
   , insertAll
   , updateTx
@@ -46,9 +45,8 @@ import RIO hiding (LogFunc, isNothing, on, (^.))
 import RIO.List ((\\))
 import qualified RIO.List as L
 import qualified RIO.Map as M
-import qualified RIO.NonEmpty as N
+import qualified RIO.NonEmpty as NE
 import qualified RIO.Text as T
-import qualified RIO.Vector as V
 
 runDB
   :: MonadUnliftIO m
@@ -246,10 +244,10 @@ paths2IDs =
     . fmap (first pathList)
   where
     pathList (AcntPath t []) = atName t :| []
-    pathList (AcntPath t ns) = N.reverse $ atName t :| ns
+    pathList (AcntPath t ns) = NE.reverse $ atName t :| ns
 
 -- none of these errors should fire assuming that input is sorted and unique
-trimNames :: [N.NonEmpty T.Text] -> [AcntID]
+trimNames :: [NE.NonEmpty T.Text] -> [AcntID]
 trimNames = fmap (T.intercalate "_" . reverse) . trimAll 0
   where
     trimAll _ [] = []
@@ -270,10 +268,10 @@ trimNames = fmap (T.intercalate "_" . reverse) . trimAll 0
                   [] -> [trim i y]
                   _ -> trimAll (i + 1) (reverse $ y : ys)
              in (new, [], reverse next ++ old)
-    trim i = N.take (i + 1)
+    trim i = NE.take (i + 1)
     err msg = errorWithoutStackTrace $ "Import.Database.Ops.hs: " ++ msg
 
-(!?) :: N.NonEmpty a -> Int -> Maybe a
+(!?) :: NE.NonEmpty a -> Int -> Maybe a
 xs !? n
   | n < 0 = Nothing
   -- Definition adapted from GHC.List
@@ -410,7 +408,7 @@ eitherHash t o f g = do
   let h = hash o
   let c = CommitR h t
   hs <- askDBState kmNewCommits
-  if h `elem` hs then Left <$> f c else Right <$> g c
+  if h `elem` hs then Right <$> g c else Left <$> f c
 
 whenHash_
   :: (Hashable a, MonadFinance m)
@@ -424,160 +422,184 @@ whenHash_ t o f = do
   hs <- askDBState kmNewCommits
   if h `elem` hs then Just . (c,) <$> f else return Nothing
 
-insertEntry :: MonadSqlQuery m => TransactionRId -> KeyEntry -> m EntryRId
+-- resolveEntry :: (MonadInsertError m, MonadFinance m) => BalEntry -> m KeyEntry
-insertEntry
+-- resolveEntry s@InsertEntry {feEntry = e@Entry {eValue, eTags, eAcnt}, feCurrency} = do
-  t
+--   let aRes = lookupAccountKey eAcnt
-  InsertEntry
+--   let cRes = lookupCurrencyKey feCurrency
-    { feEntry = Entry {eValue, eTags, eAcnt, eComment}
+--   let sRes = lookupAccountSign eAcnt
-    , feCurrency
+--   let tagRes = combineErrors $ fmap lookupTag eTags
-    , feIndex
+--   -- TODO correct sign here?
-    , feDeferred
+--   -- TODO lenses would be nice here
-    } =
+--   combineError (combineError3 aRes cRes sRes (,,)) tagRes $
-    do
+--     \(aid, cid, sign) tags ->
-      k <- insert $ EntryR t feCurrency eAcnt eComment eValue feIndex cval ctype deflink
+--       s
-      mapM_ (insert_ . TagRelationR k) eTags
+--         { feCurrency = cid
-      return k
+--         , feEntry = e {eAcnt = aid, eValue = fromIntegral (sign2Int sign) * eValue, eTags = tags}
-    where
+--         }
-      (cval, ctype, deflink) = case feDeferred of
-        (Just (EntryLinked index scale)) -> (Just scale, Nothing, Just $ fromIntegral index)
-        (Just (EntryBalance target)) -> (Just target, Just TBalance, Nothing)
-        (Just (EntryPercent target)) -> (Just target, Just TPercent, Nothing)
-        Nothing -> (Nothing, Just TFixed, Nothing)
-
-resolveEntry :: (MonadInsertError m, MonadFinance m) => BalEntry -> m KeyEntry
-resolveEntry s@InsertEntry {feEntry = e@Entry {eValue, eTags, eAcnt}, feCurrency} = do
-  let aRes = lookupAccountKey eAcnt
-  let cRes = lookupCurrencyKey feCurrency
-  let sRes = lookupAccountSign eAcnt
-  let tagRes = combineErrors $ fmap lookupTag eTags
-  -- TODO correct sign here?
-  -- TODO lenses would be nice here
-  combineError (combineError3 aRes cRes sRes (,,)) tagRes $
-    \(aid, cid, sign) tags ->
-      s
-        { feCurrency = cid
-        , feEntry = e {eAcnt = aid, eValue = fromIntegral (sign2Int sign) * eValue, eTags = tags}
-        }
 
 readUpdates
   :: (MonadInsertError m, MonadSqlQuery m)
   => [Int]
-  -> m ([ReadEntry], [UpdateEntrySet])
+  -> m ([ReadEntry], [Either TotalUpdateEntrySet FullUpdateEntrySet])
 readUpdates hashes = do
   xs <- selectE $ do
-    (commits :& txs :& entries) <-
+    (commits :& txs :& entrysets :& entries) <-
       E.from
         $ E.table @CommitR
           `E.innerJoin` E.table @TransactionR
         `E.on` (\(c :& t) -> c ^. CommitRId ==. t ^. TransactionRCommit)
+          `E.innerJoin` E.table @EntrySetR
+        `E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction)
           `E.innerJoin` E.table @EntryR
-        `E.on` (\(_ :& t :& e) -> t ^. TransactionRId ==. e ^. EntryRTransaction)
+        `E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset)
     E.where_ $ commits ^. CommitRHash `E.in_` E.valList hashes
     return
-      ( txs ^. TransactionRDeferred
+      ( entrysets ^. EntrySetRRebalance
+      ,
+        (
+          ( entrysets ^. EntrySetRId
           , txs ^. TransactionRDate
+          , entrysets ^. EntrySetRCurrency
+          )
         , entries
         )
-  let (toUpdate, toRead) =
+      )
-        bimap unpack (fmap makeRE . unpack) $
+  let (toUpdate, toRead) = L.partition (E.unValue . fst) xs
-          L.partition (\(d, _, _) -> E.unValue d) xs
+  toUpdate' <- liftExcept $ mapErrors makeUES $ groupKey (\(i, _, _) -> i) (snd <$> toUpdate)
-  toUpdate' <-
+  return (makeRE . snd <$> toRead, toUpdate')
-    liftExcept $
-      mapErrors makeUES $
-        second (fmap snd) <$> groupWith uGroup toUpdate
-  return (toRead, toUpdate')
   where
-    unpack = fmap (\(_, d, e) -> (E.unValue d, (entityKey e, entityVal e)))
+    makeUES ((_, day, curID), es) = do
-    uGroup (day, (_, e)) = (day, entryRCurrency e, entryRTransaction e)
+      let res =
-    makeUES ((day, cur, _), es) = do
+            bimap NE.nonEmpty NE.nonEmpty $
-      let (froms, tos) =
+              NE.partition ((< 0) . entryRIndex . snd) $
-            L.partition ((< 0) . entryRIndex . snd) $
+                NE.sortWith (entryRIndex . snd) $
-              L.sortOn (entryRIndex . snd) es
+                  fmap (\e -> (entityKey e, entityVal e)) es
+      case res of
+        (Just froms, Just tos) -> do
           let tot = sum $ fmap (entryRValue . snd) froms
-      (from0, fromRO, fromUnk, fromVec) <- splitFrom $ reverse froms
+          (from0, fromRO, fromUnkVec) <- splitFrom $ NE.reverse froms
-      (to0, toRO, toUnk, toLink0, toLinkN) <- splitTo fromVec tos
+          (from0', fromUnk, to0, toRO, toUnk) <- splitTo from0 fromUnkVec tos
-      return
+          -- TODO WAP (wet ass programming)
+          return $ case from0' of
+            Left x ->
+              Left $
                 UpdateEntrySet
-          { utDate = day
+                  { utDate = E.unValue day
-          , utCurrency = cur
+                  , utCurrency = E.unValue curID
-          , utFrom0 = from0
+                  , utFrom0 = x
                   , utTo0 = to0
                   , utFromRO = fromRO
                   , utToRO = toRO
-          , utToUnkLink0 = toLink0
-          , utPairs = toLinkN
                   , utFromUnk = fromUnk
                   , utToUnk = toUnk
                   , utTotalValue = tot
                   }
-    makeRE (d, (_, e)) =
+            Right x ->
-      ReadEntry
+              Right $
-        { reDate = d
+                UpdateEntrySet
-        , reCurrency = entryRCurrency e
+                  { utDate = E.unValue day
+                  , utCurrency = E.unValue curID
+                  , utFrom0 = x
+                  , utTo0 = to0
+                  , utFromRO = fromRO
+                  , utToRO = toRO
+                  , utFromUnk = fromUnk
+                  , utToUnk = toUnk
+                  , utTotalValue = ()
+                  }
+        _ -> throwError undefined
+    makeRE ((_, day, curID), entry) =
+      let e = entityVal entry
+       in ReadEntry
+            { reDate = E.unValue day
+            , reCurrency = E.unValue curID
             , reAcnt = entryRAccount e
             , reValue = entryRValue e
             }
 
 splitFrom
-  :: [(EntryRId, EntryR)]
+  :: NonEmpty (EntryRId, EntryR)
-  -> InsertExcept (UEBlank, [UE_RO], [UEUnk], Vector (Maybe UEUnk))
+  -> InsertExcept (Either UEBlank (Either UE_RO UEUnk), [UE_RO], [UEUnk])
-splitFrom from = do
+splitFrom (f0 :| fs) = do
   -- ASSUME entries are sorted by index
-  (primary, rest) <- case from of
+  -- TODO combine errors here
-    ((i, e) : xs) -> return (makeUnkUE i e, xs)
+  let f0Res = readDeferredValue f0
-    _ -> throwError $ InsertException undefined
+  let fsRes = mapErrors splitDeferredValue fs
-  rest' <- mapErrors splitDeferredValue rest
+  combineErrorM f0Res fsRes $ \f0' fs' -> do
-  let idxVec = V.fromList $ fmap (either (const Nothing) Just) rest'
+    let (ro, unk) = partitionEithers fs'
-  let (ro, toBal) = partitionEithers rest'
+    -- let idxVec = V.fromList $ fmap (either (const Nothing) Just) fs'
-  return (primary, ro, toBal, idxVec)
+    return (f0', ro, unk)
 
 splitTo
-  :: Vector (Maybe UEUnk)
+  :: Either UEBlank (Either UE_RO UEUnk)
-  -> [(EntryRId, EntryR)]
+  -> [UEUnk]
+  -> NonEmpty (EntryRId, EntryR)
   -> InsertExcept
-      ( UEBlank
+      ( Either (UEBlank, [UELink]) (Either UE_RO (UEUnk, [UELink]))
+      , [(UEUnk, [UELink])]
+      , UEBlank
       , [UE_RO]
       , [UEUnk]
-      , [UELink]
-      , [(UEUnk, [UELink])]
       )
-splitTo froms tos = do
+splitTo from0 fromUnk (t0 :| ts) = do
   -- How to split the credit side of the database transaction in 1024 easy
   -- steps:
   --
-  -- 1. ASSUME the entries are sorted by index. Isolate the first as the
+  -- 1. Split incoming entries (except primary) into those with links and not
-  --    primary and puke in user's face if list is empty (which it should never
+  let (unlinked, linked) = partitionEithers $ fmap splitLinked ts
-  --    be)
-  (primary, rest) <- case tos of
-    ((i, e) : xs) -> return (makeUnkUE i e, xs)
-    _ -> throwError $ InsertException undefined
 
-  -- 1. Split the entries based on if they have a link
+  -- 2. For unlinked entries, split into read-only and unknown entries
-  let (unlinked, linked) = partitionEithers $ fmap splitLinked rest
-
-  -- 2. Split unlinked based on if they have a balance target
   let unlinkedRes = partitionEithers <$> mapErrors splitDeferredValue unlinked
 
-  -- 3. Split paired entries by link == 0 (which are special) or link > 0
+  -- 3. For linked entries, split into those that link to the primary debit
-  let (paired0, pairedN) = second (groupKey id) $ L.partition ((== 0) . fst) linked
+  --    entry and not
-  let paired0Res = mapErrors (makeLinkUnk . snd) paired0
+  let (linked0, linkedN) = second (groupKey id) $ L.partition ((== 0) . fst) linked
 
-  -- 4. Group linked entries (which now have links > 0) according to the debit
+  -- 4. For linked entries that don't link to the primary debit entry, split
-  --    entry to which they are linked. If the debit entry cannot be found or
+  --    into those that link to an unknown debit entry or not. Those that
-  --    if the linked entry has no scale, blow up in user's face. If the
+  --    are not will be read-only and those that are will be collected with
-  --    debit entry is read-only (signified by Nothing in the 'from' array)
+  --    their linked debit entry
-  --    then consider the linked entry as another credit read-only entry
+  let linkedRes = zipPaired fromUnk linkedN
-  let pairedRes = partitionEithers <$> mapErrors splitPaired pairedN
 
-  combineError3 unlinkedRes paired0Res pairedRes $
+  -- 5. For entries linked to the primary debit entry, turn them into linked
-    \(ro, toBal) paired0' (pairedUnk, pairedRO) ->
+  --    entries (lazily only used when needed later)
-      (primary, ro ++ concat pairedRO, toBal, paired0', pairedUnk)
+  let from0Res = mapErrors (makeLinkUnk . snd) linked0
+
+  combineErrorM3 from0Res linkedRes unlinkedRes $
+    -- 6. Depending on the type of primary debit entry we have, add linked
+    --    entries if it is either an unknown or a blank (to be solved) entry,
+    --    or turn the remaining linked entries to read-only and add to the other
+    --    read-only entries
+    \from0Links (fromUnk', toROLinkedN) (toROUnlinked, toUnk) -> do
+      let (from0', toROLinked0) = case from0 of
+            Left blnk -> (Left (blnk, from0Links), [])
+            Right (Left ro) -> (Right $ Left ro, makeRoUE . snd . snd <$> linked0)
+            Right (Right unk) -> (Right $ Right (unk, from0Links), [])
+      return (from0', fromUnk', primary, toROLinked0 ++ toROLinkedN ++ toROUnlinked, toUnk)
   where
+    primary = uncurry makeUnkUE t0
     splitLinked t@(_, e) = maybe (Left t) (Right . (,t)) $ entryRCachedLink e
-    splitPaired (lnk, ts) = case froms V.!? (lnk - 1) of
+
-      Just (Just f) -> Left . (f,) <$> mapErrors makeLinkUnk ts
+-- ASSUME from and toLinked are sorted according to index and 'fst' respectively
-      Just Nothing -> return $ Right $ makeRoUE . snd <$> ts
+zipPaired
-      Nothing -> throwError $ InsertException undefined
+  :: [UEUnk]
+  -> [(Int, NonEmpty (EntryRId, EntryR))]
+  -> InsertExcept ([(UEUnk, [UELink])], [UE_RO])
+zipPaired = go ([], [])
+  where
+    go (facc, tacc) (f : fs) ((ti, tls) : ts)
+      | ueIndex f == ti = do
+          tls' <- mapErrors makeLinkUnk tls
+          go ((f, NE.toList tls') : facc, tacc) fs ts
+      | otherwise = go ((f, []) : facc, tacc ++ toRO tls) fs ts
+    go (facc, tacc) fs ts =
+      return
+        ( reverse facc ++ ((,[]) <$> fs)
+        , tacc ++ concatMap (toRO . snd) ts
+        )
+    toRO = NE.toList . fmap (makeRoUE . snd)
+
+makeLinkUnk :: (EntryRId, EntryR) -> InsertExcept UELink
 makeLinkUnk (k, e) =
   maybe
     (throwError $ InsertException undefined)
@@ -585,13 +607,21 @@ splitTo froms tos = do
     $ entryRCachedValue e
 
 splitDeferredValue :: (EntryRId, EntryR) -> InsertExcept (Either UE_RO UEUnk)
-splitDeferredValue (k, e) = case (entryRCachedValue e, entryRCachedType e) of
+splitDeferredValue p = do
-  (Nothing, Just TFixed) -> return $ Left $ makeRoUE e
+  res <- readDeferredValue p
+  case res of
+    Left _ -> throwError $ InsertException undefined
+    Right x -> return x
+
+readDeferredValue :: (EntryRId, EntryR) -> InsertExcept (Either UEBlank (Either UE_RO UEUnk))
+readDeferredValue (k, e) = case (entryRCachedValue e, entryRCachedType e) of
+  (Nothing, Just TFixed) -> return $ Right $ Left $ makeRoUE e
   (Just v, Just TBalance) -> go EVBalance v
   (Just v, Just TPercent) -> go EVPercent v
+  (Nothing, Nothing) -> return $ Left $ makeUnkUE k e
   _ -> throwError $ InsertException undefined
   where
-    go c = return . Right . fmap c . makeUE k e
+    go c = return . Right . Right . fmap c . makeUE k e
 
 makeUE :: i -> EntryR -> v -> UpdateEntry i v
 makeUE k e v = UpdateEntry k (entryRAccount e) v (entryRIndex e)
@@ -618,16 +648,40 @@ insertAll ebs = do
     getCommit (BudgetCommit c _) = c
 
 insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m ()
-insertTx c InsertTx {itxDate, itxDescr, itxEntries, itxCommit} = do
+insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxCommit} = do
-  let anyDeferred = any (isJust . feDeferred) itxEntries
+  k <- insert $ TransactionR c itxDate itxDescr
-  k <- insert $ TransactionR c itxDate itxDescr anyDeferred
+  mapM_ (uncurry (insertEntrySet k)) $ zip [0 ..] (NE.toList itxEntrySets)
-  mapM_ (go k) itxEntries
   where
-    go k tx = do
+    insertEntrySet tk i InsertEntrySet {iesCurrency, iesFromEntries, iesToEntries} = do
-      ek <- insertEntry k tx
+      let fs = NE.toList iesFromEntries
+      let ts = NE.toList iesToEntries
+      let rebalance = any (isJust . ieDeferred) (fs ++ ts)
+      esk <- insert $ EntrySetR tk iesCurrency i rebalance
+      mapM_ (uncurry (go esk)) $ zip [0 ..] ts ++ zip (negate <$> [1 ..]) fs
+    go k i e = do
+      ek <- insertEntry k i e
       case itxCommit of
         BudgetCommit _ name -> insert_ $ BudgetLabelR ek name
         _ -> return ()
 
+insertEntry :: MonadSqlQuery m => EntrySetRId -> Int -> KeyEntry -> m EntryRId
+insertEntry
+  k
+  i
+  InsertEntry
+    { ieEntry = Entry {eValue, eTags, eAcnt, eComment}
+    , ieDeferred
+    } =
+    do
+      ek <- insert $ EntryR k eAcnt eComment eValue i cval ctype deflink
+      mapM_ (insert_ . TagRelationR ek) eTags
+      return ek
+    where
+      (cval, ctype, deflink) = case ieDeferred of
+        (Just (EntryLinked index scale)) -> (Just scale, Nothing, Just $ fromIntegral index)
+        (Just (EntryBalance target)) -> (Just target, Just TBalance, Nothing)
+        (Just (EntryPercent target)) -> (Just target, Just TPercent, Nothing)
+        Nothing -> (Nothing, Just TFixed, Nothing)
+
 updateTx :: MonadSqlQuery m => UEBalanced -> m ()
 updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. unStaticValue ueValue]

lib/Internal/Types/Database.hs

@@ -44,11 +44,15 @@ TransactionR sql=transactions
     commit CommitRId OnDeleteCascade
     date Day
     description T.Text
-    deferred Bool
     deriving Show Eq
-EntryR sql=entries
+EntrySetR sql=entry_sets
     transaction TransactionRId OnDeleteCascade
     currency CurrencyRId OnDeleteCascade
+    index Int
+    rebalance Bool
+    deriving Show Eq
+EntryR sql=entries
+    entryset EntrySetRId OnDeleteCascade 
     account AccountRId OnDeleteCascade
     memo T.Text
     value Rational

lib/Internal/Types/Dhall.hs

@@ -459,7 +459,7 @@ data Statement = Statement
   , stmtTxOpts :: !(TxOpts T.Text)
   , stmtSkipLines :: !Natural
   }
-  deriving (Eq, Hashable, Generic, FromDhall)
+  deriving (Eq, Hashable, Generic, FromDhall, Show)
 
 -- | the value of a field in entry (text version)
 -- can either be a raw (constant) value, a lookup from the record, or a map

lib/Internal/Types/Main.hs

@@ -37,6 +37,7 @@ data ConfigHashes = ConfigHashes
 type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
 
 data CurrencyPrec = CurrencyPrec {cpID :: !CurrencyRId, cpPrec :: !Natural}
+  deriving (Show)
 
 type CurrencyMap = M.Map CurID CurrencyPrec
 
@@ -50,6 +51,7 @@ data DBState = DBState
   , kmStatementInterval :: !DaySpan
   , kmNewCommits :: ![Int]
   }
+  deriving (Show)
 
 data DBUpdates = DBUpdates
   { duOldCommits :: ![Int]
@@ -79,7 +81,7 @@ data UpdateEntry i v = UpdateEntry
   { ueID :: !i
   , ueAcnt :: !AccountRId
   , ueValue :: !v
-  , ueIndex :: !Int -- TODO this isn't needed for primary entries
+  , ueIndex :: !Int
   }
 
 data CurrencyRound = CurrencyRound CurID Natural
@@ -107,32 +109,27 @@ type UE_RO = UpdateEntry () StaticValue
 
 type UEBalanced = UpdateEntry EntryRId StaticValue
 
-data UpdateEntrySet = UpdateEntrySet
+data UpdateEntrySet f t = UpdateEntrySet
-  { utFrom0 :: !UEBlank
+  { utFrom0 :: !f
   , utTo0 :: !UEBlank
-  , utPairs :: ![(UEUnk, [UELink])]
+  , utFromUnk :: ![(UEUnk, [UELink])]
-  , utFromUnk :: ![UEUnk]
   , utToUnk :: ![UEUnk]
-  , utToUnkLink0 :: ![UELink]
   , utFromRO :: ![UE_RO]
   , utToRO :: ![UE_RO]
   , utCurrency :: !CurrencyRId
   , utDate :: !Day
-  , utTotalValue :: !Rational
+  , utTotalValue :: !t
   }
 
+type TotalUpdateEntrySet = UpdateEntrySet (UEBlank, [UELink]) Rational
+
+type FullUpdateEntrySet = UpdateEntrySet (Either UE_RO (UEUnk, [UELink])) ()
+
 data EntryBin
-  = ToUpdate UpdateEntrySet
+  = ToUpdate (Either TotalUpdateEntrySet FullUpdateEntrySet)
   | ToRead ReadEntry
   | ToInsert (Tx TxCommit)
 
-data InsertEntry a c t = InsertEntry
-  { feCurrency :: !c
-  , feIndex :: !Int
-  , feDeferred :: !(Maybe DBDeferred)
-  , feEntry :: !(Entry a Rational t)
-  }
-
 type KeyEntry = InsertEntry AccountRId CurrencyRId TagRId
 
 type BalEntry = InsertEntry AcntID CurID TagID
@@ -206,49 +203,75 @@ accountSign IncomeT = Credit
 accountSign LiabilityT = Credit
 accountSign EquityT = Credit
 
-data HalfEntrySet a c t v = HalfEntrySet
+data HalfEntrySet v0 vN = HalfEntrySet
-  { hesPrimary :: !(Entry a () t)
+  { hesPrimary :: !(Entry AcntID v0 TagID)
-  , hesOther :: ![Entry a v t]
+  , hesOther :: ![Entry AcntID vN TagID]
   }
+  deriving (Show)
 
-data EntrySet a c t v v' = EntrySet
+data EntrySet v0 vp0 vpN vtN = EntrySet
-  { esTotalValue :: !v'
+  { esTotalValue :: !v0
-  , esCurrency :: !c
+  , esCurrency :: !CurrencyPrec
-  , esFrom :: !(HalfEntrySet a c t (EntryValue v))
+  , esFrom :: !(HalfEntrySet vp0 vpN)
-  , esTo :: !(HalfEntrySet a c t (LinkDeferred v))
+  , esTo :: !(HalfEntrySet () vtN)
   }
+  deriving (Show)
 
-data TxCommit = HistoryCommit CommitR | BudgetCommit CommitR T.Text deriving (Eq, Ord)
+type TotalEntrySet v0 vpN vtN = EntrySet v0 () vpN vtN
+
+type FullEntrySet vp0 vpN vtN = EntrySet () vp0 vpN vtN
+
+type PrimaryEntrySet =
+  TotalEntrySet
+    Rational
+    (EntryValue Rational)
+    (LinkDeferred Rational)
+
+type SecondayEntrySet =
+  FullEntrySet
+    (EntryValue Rational)
+    (EntryValue Rational)
+    (LinkDeferred Rational)
+
+type TransferEntrySet = SecondayEntrySet
+
+type ShadowEntrySet =
+  TotalEntrySet
+    Double
+    (EntryValue Rational)
+    (LinkDeferred Rational)
+
+data TxCommit = HistoryCommit CommitR | BudgetCommit CommitR T.Text
+  deriving (Eq, Ord, Show)
 
 data Tx k = Tx
   { txDescr :: !T.Text
   , txDate :: !Day
-  , txPrimary :: !(EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational))
+  , txPrimary :: !(Either PrimaryEntrySet TransferEntrySet)
-  , txOther :: ![EntrySet AcntID CurrencyPrec TagID Rational (Either Double (EntryValue Rational))]
+  , txOther :: ![Either SecondayEntrySet ShadowEntrySet]
   , txCommit :: !k
   }
-  deriving (Generic)
+  deriving (Generic, Show)
+
+data InsertEntry a c t = InsertEntry
+  { ieDeferred :: !(Maybe DBDeferred)
+  , ieEntry :: !(Entry a Rational t)
+  }
+
+data InsertEntrySet = InsertEntrySet
+  { iesCurrency :: !CurrencyRId
+  , iesFromEntries :: !(NonEmpty (InsertEntry AccountRId CurrencyRId TagRId))
+  , iesToEntries :: !(NonEmpty (InsertEntry AccountRId CurrencyRId TagRId))
+  }
 
 data InsertTx = InsertTx
   { itxDescr :: !T.Text
   , itxDate :: !Day
-  , itxEntries :: ![InsertEntry AccountRId CurrencyRId TagRId]
+  , itxEntrySets :: !(NonEmpty InsertEntrySet)
   , itxCommit :: !TxCommit
   }
   deriving (Generic)
 
-type DeferredEntrySet = EntrySet AcntID CurrencyPrec TagID Rational
-
-type BalEntrySet = EntrySet AcntID CurID TagID Rational
-
-type KeyEntrySet = EntrySet AccountRId CurrencyRId TagRId Rational
-
--- type DeferredTx = Tx [DeferredEntrySet]
-
--- type BalTx = InsertTx [BalEntry]
-
--- type KeyTx = InsertTx [KeyEntry]
-
 data Deferred a = Deferred Bool a
   deriving (Show, Functor, Foldable, Traversable)
 

lib/Internal/Utils.hs

@@ -64,7 +64,6 @@ module Internal.Utils
   , expandTransfers
   , expandTransfer
   , entryPair
-  , entryPair_
   )
 where
 
@@ -334,20 +333,21 @@ toTx
         , txDescr = trDesc
         , txCommit = ()
         , txPrimary =
+            Left $
               EntrySet
-              { esTotalValue = EntryValue TFixed $ roundPrecisionCur cur $ tgScale * fromRational trAmount
+                { esTotalValue = roundPrecisionCur cur $ tgScale * fromRational trAmount
                 , esCurrency = cur
                 , esFrom = f
                 , esTo = t
                 }
-        , txOther = ss
+        , txOther = fmap Left ss
         }
     where
       curRes = do
         m <- askDBState kmCurrency
         cur <- liftInner $ resolveCurrency m r tgCurrency
-        let fromRes = liftInner $ resolveHalfEntry resolveFromValue cur r tgFrom
+        let fromRes = liftInner $ resolveHalfEntry resolveFromValue cur r () tgFrom
-        let toRes = liftInner $ resolveHalfEntry resolveToValue cur r tgTo
+        let toRes = liftInner $ resolveHalfEntry resolveToValue cur r () tgTo
         combineError fromRes toRes (cur,,)
       subRes = mapErrors (resolveSubGetter r) tgOtherEntries
 
@@ -355,16 +355,17 @@ resolveSubGetter
   :: MonadFinance m
   => TxRecord
   -> TxSubGetter
-  -> InsertExceptT m (EntrySet AcntID CurrencyPrec TagID Rational (Either Double (EntryValue Rational)))
+  -> InsertExceptT m SecondayEntrySet
 resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
   m <- askDBState kmCurrency
   cur <- liftInner $ resolveCurrency m r tsgCurrency
-  let fromRes = resolveHalfEntry resolveFromValue cur r tsgFrom
+  let toRes = resolveHalfEntry resolveToValue cur r () tsgTo
-  let toRes = resolveHalfEntry resolveToValue cur r tsgTo
   let valRes = liftInner $ fmap (roundPrecisionCur cur) <$> resolveValue r tsgValue
-  liftInner $ combineError3 fromRes toRes valRes $ \f t v ->
+  liftInner $ combineErrorM toRes valRes $ \t v -> do
+    f <- resolveHalfEntry resolveFromValue cur r v tsgFrom
+    return $
       EntrySet
-      { esTotalValue = Right v
+        { esTotalValue = ()
         , esCurrency = cur
         , esFrom = f
         , esTo = t
@@ -375,15 +376,16 @@ resolveHalfEntry
   => (TxRecord -> n -> InsertExcept (f Double))
   -> CurrencyPrec
   -> TxRecord
+  -> v
   -> TxHalfGetter (EntryGetter n)
-  -> InsertExcept (HalfEntrySet AcntID CurrencyPrec TagID (f Rational))
+  -> InsertExcept (HalfEntrySet v (f Rational))
-resolveHalfEntry f cur r TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} =
+resolveHalfEntry f cur r v TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} =
   combineError acntRes esRes $ \a es ->
     HalfEntrySet
       { hesPrimary =
           Entry
             { eAcnt = a
-            , eValue = ()
+            , eValue = v
             , eComment = thgComment
             , eTags = thgTags
             }
@@ -913,10 +915,10 @@ unlessLefts_ e f = unlessLefts e (\x -> void (f x) >> return mzero)
 --   where
 --     go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
 
-groupKey :: Ord c => (a -> c) -> [(a, b)] -> [(a, [b])]
+groupKey :: Ord c => (a -> c) -> [(a, b)] -> [(a, NonEmpty b)]
 groupKey f = fmap go . NE.groupAllWith (f . fst)
   where
-    go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
+    go xs@((c, _) :| _) = (c, fmap snd xs)
 
 groupWith :: Ord b => (a -> b) -> [a] -> [(b, [a])]
 groupWith f = fmap go . NE.groupAllWith fst . fmap (\x -> (f x, x))
@@ -1037,56 +1039,54 @@ balanceTxs ebs =
   first concat . partitionEithers . catMaybes
     <$> evalStateT (mapErrors go $ L.sortOn binDate ebs) M.empty
   where
-    go (ToUpdate utx) = fmap (Just . Left) $ liftInnerS $ rebalanceEntrySet utx
+    go (ToUpdate utx) =
+      fmap (Just . Left) $
+        liftInnerS $
+          either rebalanceTotalEntrySet rebalanceFullEntrySet utx
     go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do
       modify $ mapAdd_ (reAcnt, reCurrency) reValue
       return Nothing
     go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate}) = do
-      e <- balanceEntrySet primaryBalance txPrimary
+      e <- either balancePrimaryEntrySet balanceSecondaryEntrySet txPrimary
-      -- TODO this logic is really stupid, I'm balancing the total twice; fix
+      let tot = sum $ fmap (eValue . ieEntry) $ NE.toList $ iesFromEntries e
-      -- will likely entail making a separate data structure for txs derived
+      es <- mapErrors (either balanceSecondaryEntrySet (balancePrimaryEntrySet . fromShadow tot)) txOther
-      -- from transfers vs statements
-      let etot = sum $ eValue . feEntry <$> filter ((< 0) . feIndex) e
-      es <- mapErrors (balanceEntrySet (secondaryBalance etot)) txOther
       let tx =
             InsertTx
               { itxDescr = txDescr
               , itxDate = txDate
-              , itxEntries = concat $ e : es
+              , itxEntrySets = e :| es
               , itxCommit = txCommit
               }
       return $ Just $ Right tx
-    primaryBalance Entry {eAcnt} c (EntryValue t v) = findBalance eAcnt c t v
+    fromShadow tot e@EntrySet {esTotalValue} = e {esTotalValue = tot * toRational esTotalValue}
-    secondaryBalance tot Entry {eAcnt} c val = case val of
-      Right (EntryValue t v) -> findBalance eAcnt c t v
-      Left v -> return $ toRational v * tot
 
 binDate :: EntryBin -> Day
-binDate (ToUpdate UpdateEntrySet {utDate}) = utDate
+binDate (ToUpdate (Right UpdateEntrySet {utDate})) = utDate
+binDate (ToUpdate (Left UpdateEntrySet {utDate})) = utDate
 binDate (ToRead ReadEntry {reDate}) = reDate
 binDate (ToInsert Tx {txDate}) = txDate
 
 type EntryBals = M.Map (AccountRId, CurrencyRId) Rational
 
-data UpdateEntryType a
+data UpdateEntryType a b
   = UET_ReadOnly UE_RO
-  | UET_Unk UEUnk
+  | UET_Unk a
-  | UET_Linked a
+  | UET_Linked b
 
 -- TODO make sure new values are rounded properly here
-rebalanceEntrySet :: UpdateEntrySet -> State EntryBals [UEBalanced]
+rebalanceTotalEntrySet :: TotalUpdateEntrySet -> State EntryBals [UEBalanced]
-rebalanceEntrySet
+rebalanceTotalEntrySet
   UpdateEntrySet
-    { utFrom0
+    { utFrom0 = (f0, f0links)
     , utTo0
-    , utPairs
+    , -- , utPairs
-    , utFromUnk
+    utFromUnk
     , utToUnk
     , utFromRO
     , utToRO
     , utCurrency
-    , utToUnkLink0
+    , -- , utToUnkLink0
-    , utTotalValue
+    utTotalValue
     } =
     do
       (f0val, (tpairs, fs)) <-
@@ -1094,10 +1094,9 @@ rebalanceEntrySet
           foldM goFrom (utTotalValue, []) $
             L.sortOn idx $
               (UET_ReadOnly <$> utFromRO)
-                ++ (UET_Unk <$> utFromUnk)
+                ++ (UET_Linked <$> utFromUnk)
-                ++ (UET_Linked <$> utPairs)
+      let f0' = f0 {ueValue = StaticValue f0val}
-      let f0 = utFrom0 {ueValue = StaticValue f0val}
+      let tsLink0 = fmap (unlink (-f0val)) f0links
-      let tsLink0 = fmap (unlink (-f0val)) utToUnkLink0
       (t0val, tsUnk) <-
         fmap (second catMaybes) $
           foldM goTo (-utTotalValue, []) $
@@ -1106,7 +1105,7 @@ rebalanceEntrySet
                 ++ (UET_Unk <$> utToUnk)
                 ++ (UET_ReadOnly <$> utToRO)
       let t0 = utTo0 {ueValue = StaticValue t0val}
-      return (f0 : fs ++ (t0 : tsUnk))
+      return (f0' : fs ++ (t0 : tsUnk))
     where
       project f _ _ (UET_ReadOnly e) = f e
       project _ f _ (UET_Unk e) = f e
@@ -1149,13 +1148,126 @@ rebalanceEntrySet
         return v
       unlink v e = e {ueValue = StaticValue $ v * unLinkScale (ueValue e)}
 
-balanceEntrySet
+rebalanceFullEntrySet :: FullUpdateEntrySet -> State EntryBals [UEBalanced]
+rebalanceFullEntrySet
+  UpdateEntrySet
+    { utFrom0
+    , utTo0
+    , -- , utPairs
+    utFromUnk
+    , utToUnk
+    , utFromRO
+    , utToRO
+    , utCurrency
+    -- , utToUnkLink0
+    } =
+    do
+      let (f_ro, f_lnkd) = case utFrom0 of
+            Left x -> (x : utFromRO, utFromUnk)
+            Right x -> (utFromRO, x : utFromUnk)
+      (tpairs, fs) <-
+        fmap partitionEithers $
+          foldM goFrom [] $
+            L.sortOn idx $
+              (UET_ReadOnly <$> f_ro)
+                ++ (UET_Linked <$> f_lnkd)
+      tsUnk <-
+        fmap catMaybes $
+          foldM goTo [] $
+            L.sortOn idx2 $
+              (UET_Linked <$> tpairs)
+                ++ (UET_Unk <$> utToUnk)
+                ++ (UET_ReadOnly <$> utToRO)
+      let t0val = -(entrySum fs + entrySum tsUnk)
+      let t0 = utTo0 {ueValue = t0val}
+      return (fs ++ (t0 : tsUnk))
+    where
+      project f _ _ (UET_ReadOnly e) = f e
+      project _ f _ (UET_Unk e) = f e
+      project _ _ f (UET_Linked p) = f p
+      idx = project ueIndex ueIndex (ueIndex . fst)
+      idx2 = project ueIndex ueIndex ueIndex
+      -- TODO the sum accumulator thing is kinda awkward
+      goFrom es (UET_ReadOnly e) = do
+        _ <- updateFixed e
+        return es
+      goFrom esPrev (UET_Unk e) = do
+        v <- updateUnknown e
+        return $ Right e {ueValue = StaticValue v} : esPrev
+      goFrom esPrev (UET_Linked (e0, es)) = do
+        v <- updateUnknown e0
+        let e0' = Right $ e0 {ueValue = StaticValue v}
+        let es' = fmap (Left . unlink (-v)) es
+        return $ (e0' : es') ++ esPrev
+      goTo esPrev (UET_ReadOnly e) = do
+        _ <- updateFixed e
+        return esPrev
+      goTo esPrev (UET_Linked e) = do
+        _ <- updateFixed e
+        return $ Just e : esPrev
+      goTo esPrev (UET_Unk e) = do
+        v <- updateUnknown e
+        return $ Just e {ueValue = StaticValue v} : esPrev
+      updateFixed :: UpdateEntry i StaticValue -> State EntryBals Rational
+      updateFixed e = do
+        let v = unStaticValue $ ueValue e
+        modify $ mapAdd_ (ueAcnt e, utCurrency) v
+        return v
+      updateUnknown e = do
+        let key = (ueAcnt e, utCurrency)
+        curBal <- gets (M.findWithDefault 0 key)
+        let v = case ueValue e of
+              EVPercent p -> p * curBal
+              EVBalance p -> p - curBal
+        modify $ mapAdd_ key v
+        return v
+      unlink v e = e {ueValue = StaticValue $ v * unLinkScale (ueValue e)}
+      entrySum = sum . fmap ueValue
+
+balanceSecondaryEntrySet
   :: (MonadInsertError m, MonadFinance m)
-  => (Entry AccountRId AcntSign TagRId -> CurrencyRId -> v -> State EntryBals Rational)
+  => SecondayEntrySet
-  -> DeferredEntrySet v
+  -> StateT EntryBals m InsertEntrySet
-  -> StateT EntryBals m [KeyEntry]
+balanceSecondaryEntrySet
-balanceEntrySet
+  EntrySet
-  findTot
+    { esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
+    , esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
+    , esCurrency = CurrencyPrec {cpID = curID, cpPrec = precision}
+    } =
+    do
+      fs' <- mapErrors resolveAcntAndTags (f0 :| fs)
+      t0' <- resolveAcntAndTags t0
+      ts' <- mapErrors resolveAcntAndTags ts
+      let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a) curID
+      fs'' <- mapErrors balFromEntry fs'
+      let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs''
+      let balToEntry = balanceEntry (balanceLinked fv curID precision) curID
+      ts'' <- mapErrors balToEntry ts'
+      -- TODO wet
+      let (acntID, sign) = eAcnt t0'
+      let t0Val = -(entrySum (NE.toList fs'') + entrySum ts'')
+      modify (mapAdd_ (acntID, curID) t0Val)
+      let t0'' =
+            InsertEntry
+              { ieEntry = t0' {eValue = fromIntegral (sign2Int sign) * t0Val, eAcnt = acntID}
+              , ieDeferred = Nothing
+              }
+      -- TODO don't record index here, just keep them in order and let the
+      -- insertion function deal with assigning the index
+      return $
+        InsertEntrySet
+          { iesCurrency = curID
+          , iesFromEntries = fs''
+          , iesToEntries = t0'' :| ts''
+          }
+    where
+      entrySum = sum . fmap (eValue . ieEntry)
+
+balancePrimaryEntrySet
+  :: (MonadInsertError m, MonadFinance m)
+  => PrimaryEntrySet
+  -> StateT EntryBals m InsertEntrySet
+balancePrimaryEntrySet
   EntrySet
     { esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
     , esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
@@ -1163,53 +1275,48 @@ balanceEntrySet
     , esTotalValue
     } =
     do
-      -- 1. Resolve tag and accout ids in primary entries since we (might) need
-      --    them later to calculate the total value of the transaction.
       let f0res = resolveAcntAndTags f0
       let t0res = resolveAcntAndTags t0
-      combineErrorM f0res t0res $ \f0' t0' -> do
+      let fsres = mapErrors resolveAcntAndTags fs
-        -- 2. Compute total value of transaction using the primary debit entry
+      let tsres = mapErrors resolveAcntAndTags ts
-        tot <- liftInnerS $ findTot f0' curID esTotalValue
+      combineErrorM (combineError f0res fsres (,)) (combineError t0res tsres (,)) $
-
+        \(f0', fs') (t0', ts') -> do
-        -- 3. Balance all debit entries (including primary). Note the negative
-        --    indices, which will signify them to be debit entries when updated
-        --    later.
           let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a) curID
-        fs' <- doEntries balFromEntry curID tot f0' fs (NE.iterate (+ (-1)) (-1))
+          fs'' <- doEntries balFromEntry curID esTotalValue f0' fs'
 
-        -- 4. Build an array of debit values be linked as desired in credit entries
+          let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs''
-        let fv = V.fromList $ fmap (eValue . feEntry) fs'
 
-        -- 4. Balance credit entries (including primary) analogously.
           let balToEntry = balanceEntry (balanceLinked fv curID precision) curID
-        ts' <- doEntries balToEntry curID (-tot) t0' ts (NE.iterate (+ 1) 0)
+          ts'' <- doEntries balToEntry curID (-esTotalValue) t0' ts'
-        return $ fs' ++ ts'
+          return $
+            InsertEntrySet
+              { iesCurrency = curID
+              , iesFromEntries = fs''
+              , iesToEntries = ts''
+              }
 
 doEntries
   :: (MonadInsertError m)
-  => (Int -> Entry AcntID v TagID -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId))
+  => (Entry (AccountRId, AcntSign) v TagRId -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId))
   -> CurrencyRId
   -> Rational
-  -> Entry AccountRId AcntSign TagRId
+  -> Entry (AccountRId, AcntSign) () TagRId
-  -> [Entry AcntID v TagID]
+  -> [Entry (AccountRId, AcntSign) v TagRId]
-  -> NonEmpty Int
+  -> StateT EntryBals m (NonEmpty (InsertEntry AccountRId CurrencyRId TagRId))
-  -> StateT EntryBals m [InsertEntry AccountRId CurrencyRId TagRId]
+doEntries f curID tot e@Entry {eAcnt = (acntID, sign)} es = do
-doEntries f curID tot e es (i0 :| iN) = do
+  es' <- mapErrors f es
-  es' <- mapErrors (uncurry f) $ zip iN es
   let e0val = tot - entrySum es'
   -- TODO not dry
-  let s = fromIntegral $ sign2Int (eValue e) -- NOTE hack
+  let s = fromIntegral $ sign2Int sign -- NOTE hack
-  modify (mapAdd_ (eAcnt e, curID) tot)
+  modify (mapAdd_ (acntID, curID) e0val)
   let e' =
         InsertEntry
-          { feEntry = e {eValue = s * e0val}
+          { ieEntry = e {eValue = s * e0val, eAcnt = acntID}
-          , feCurrency = curID
+          , ieDeferred = Nothing
-          , feDeferred = Nothing
-          , feIndex = i0
           }
-  return $ e' : es'
+  return $ e' :| es'
   where
-    entrySum = sum . fmap (eValue . feEntry)
+    entrySum = sum . fmap (eValue . ieEntry)
 
 liftInnerS :: Monad m => StateT e Identity a -> StateT e m a
 liftInnerS = mapStateT (return . runIdentity)
@@ -1248,38 +1355,30 @@ balanceDeferred curID acntID (EntryValue t v) = do
   return (newval, d)
 
 balanceEntry
-  :: (MonadInsertError m, MonadFinance m)
+  :: (MonadInsertError m)
   => (AccountRId -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
   -> CurrencyRId
-  -> Int
+  -> Entry (AccountRId, AcntSign) v TagRId
-  -> Entry AcntID v TagID
   -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId)
-balanceEntry f curID idx e@Entry {eValue, eAcnt, eTags} = do
+balanceEntry f curID e@Entry {eValue, eAcnt = (acntID, sign)} = do
-  let acntRes = lookupAccount eAcnt
-  let tagRes = mapErrors lookupTag eTags
-  combineErrorM acntRes tagRes $ \(acntID, sign, _) tags -> do
   let s = fromIntegral $ sign2Int sign
   (newVal, deferred) <- f acntID eValue
   modify (mapAdd_ (acntID, curID) newVal)
   return $
     InsertEntry
-        { feEntry = e {eValue = s * newVal, eAcnt = acntID, eTags = tags}
+      { ieEntry = e {eValue = s * newVal, eAcnt = acntID}
-        , feCurrency = curID
+      , ieDeferred = deferred
-        , feDeferred = deferred
-        , feIndex = idx
       }
 
 resolveAcntAndTags
   :: (MonadInsertError m, MonadFinance m)
   => Entry AcntID v TagID
-  -> m (Entry AccountRId AcntSign TagRId)
+  -> m (Entry (AccountRId, AcntSign) v TagRId)
 resolveAcntAndTags e@Entry {eAcnt, eTags} = do
   let acntRes = lookupAccount eAcnt
   let tagRes = mapErrors lookupTag eTags
-  -- TODO total hack, store account sign in the value field so I don't need to
-  -- make seperate tuple pair thing to haul it around. Weird, but it works.
   combineError acntRes tagRes $
-    \(acntID, sign, _) tags -> e {eAcnt = acntID, eTags = tags, eValue = sign}
+    \(acntID, sign, _) tags -> e {eAcnt = (acntID, sign), eTags = tags}
 
 findBalance
   :: AccountRId
@@ -1310,7 +1409,7 @@ expandTransfer
   -> m [Tx TxCommit]
 expandTransfer tc bounds Transfer {transAmounts, transTo, transCurrency, transFrom} = do
   txs <- mapErrors go transAmounts
-  return $ filter (inDaySpan bounds . txDate) $ concat txs
+  return $ concat txs
   where
     go
       Amount
@@ -1318,13 +1417,13 @@ expandTransfer tc bounds Transfer {transAmounts, transTo, transCurrency, transFr
         , amtValue = TransferValue {tvVal = v, tvType = t}
         , amtDesc = desc
         } =
-        withDates pat $ \day -> do
+        withDates bounds pat $ \day -> do
-          p <- entryPair_ (\_ x -> EntryValue t $ toRational x) transFrom transTo transCurrency desc v
+          p <- entryPair transFrom transTo transCurrency desc () (EntryValue t (toRational (-v)))
           return
             Tx
               { txCommit = tc
               , txDate = day
-              , txPrimary = p
+              , txPrimary = Right p
               , txOther = []
               , txDescr = desc
               }
@@ -1335,43 +1434,32 @@ entryPair
   -> TaggedAcnt
   -> CurID
   -> T.Text
-  -> Double
+  -> v0
-  -> m (EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational))
+  -> v1
-entryPair = entryPair_ (fmap (EntryValue TFixed) . roundPrecisionCur)
+  -> m (EntrySet v0 v1 v2 v3)
-
+entryPair (TaggedAcnt fa fts) (TaggedAcnt ta tts) curid com totval val1 = do
-entryPair_
-  :: (MonadInsertError m, MonadFinance m)
-  => (CurrencyPrec -> v -> v')
-  -> TaggedAcnt
-  -> TaggedAcnt
-  -> CurID
-  -> T.Text
-  -> v
-  -> m (EntrySet AcntID CurrencyPrec TagID Rational v')
-entryPair_ f from to_ curid com val = do
   cp <- lookupCurrency curid
-  return $ pair cp from to_ (f cp val)
+  return $
-  where
-    halfEntry :: a -> [t] -> HalfEntrySet a c t v
-    halfEntry a ts =
-      HalfEntrySet
-        { hesPrimary = Entry {eAcnt = a, eValue = (), eComment = com, eTags = ts}
-        , hesOther = []
-        }
-    pair cp (TaggedAcnt fa fts) (TaggedAcnt ta tts) v =
     EntrySet
       { esCurrency = cp
-        , esTotalValue = v
+      , esTotalValue = totval
-        , esFrom = halfEntry fa fts
+      , esFrom = halfEntry fa fts val1
-        , esTo = halfEntry ta tts
+      , esTo = halfEntry ta tts ()
+      }
+  where
+    halfEntry :: AcntID -> [TagID] -> v -> HalfEntrySet v v0
+    halfEntry a ts v =
+      HalfEntrySet
+        { hesPrimary = Entry {eAcnt = a, eValue = v, eComment = com, eTags = ts}
+        , hesOther = []
         }
 
 withDates
   :: (MonadFinance m, MonadInsertError m)
-  => DatePat
+  => DaySpan
+  -> DatePat
   -> (Day -> m a)
   -> m [a]
-withDates dp f = do
+withDates bounds dp f = do
-  bounds <- askDBState kmBudgetInterval
   days <- liftExcept $ expandDatePat bounds dp
   combineErrors $ fmap f days