WIP unify history and budget pipelines

dhall/Types.dhall

@@ -681,39 +681,6 @@ let Amount =
       \(v : Type) ->
         { amtWhen : w, amtValue : v, amtDesc : Text }
 
-let Exchange =
-    {-
-    A currency exchange.
-    -}
-      { xFromCur :
-          {-
-          Starting currency of the exchange.
-          -}
-          CurID
-      , xToCur :
-          {-
-          Ending currency of the exchange.
-          -}
-          CurID
-      , xAcnt :
-          {-
-          account in which the exchange will be documented.
-          -}
-          AcntID
-      , xRate :
-          {-
-          The exchange rate between the currencies.
-          -}
-          Double
-      }
-
-let TransferCurrency =
-    {-
-    Means to represent currency in a transcaction; either single fixed currency
-    or two currencies with an exchange rate.
-    -}
-      < NoX : CurID | X : Exchange >
-
 let TransferType =
     {-
     The type of a budget transfer.
@@ -1077,7 +1044,7 @@ let ShadowTransfer =
           {-
           Currency of this transfer.
           -}
-          TransferCurrency
+          CurID
       , stDesc :
           {-
           Description of this transfer.
@@ -1103,7 +1070,7 @@ let BudgetTransfer =
     {-
     A manually specified transaction for a budget
     -}
-      Transfer TaggedAcnt TransferCurrency DatePat TransferValue.Type
+      Transfer TaggedAcnt CurID DatePat TransferValue.Type
 
 let Budget =
     {-
@@ -1173,8 +1140,6 @@ in  { CurID
     , TransferMatcher
     , ShadowTransfer
     , AcntSet
-    , TransferCurrency
-    , Exchange
     , TaggedAcnt
     , AccountTree
     , Account

lib/Internal/Budget.hs

@@ -4,6 +4,7 @@ import Control.Monad.Except
 import Data.Foldable
 import Database.Persist.Monad
 import Internal.Database
+import Internal.History
 import Internal.Types.Main
 import Internal.Utils
 import RIO hiding (to)
@@ -44,9 +45,9 @@ insertBudget
       let res1 = mapErrors (insertIncome key bgtLabel intAllos bgtInterval) bgtIncomes
       let res2 = expandTransfers key bgtLabel bgtInterval bgtTransfers
       txs <- combineError (concat <$> res1) res2 (++)
-      m <- askDBState kmCurrency
+      shadow <- addShadowTransfers bgtShadowTransfers txs
-      shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs
+      (_, toIns) <- balanceTxs $ fmap ToInsert $ txs ++ shadow
-      void $ mapErrors insertBudgetTx $ balanceTransfers $ txs ++ shadow
+      void $ insertBudgetTx toIns
     where
       acntRes = mapErrors isNotIncomeAcnt alloAcnts
       intAlloRes = combineError3 pre_ tax_ post_ (,,)
@@ -61,69 +62,94 @@ insertBudget
 
 -- TODO need to systematically make this function match the history version,
 -- which will allow me to use the same balancing algorithm for both
-balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer]
+-- balanceTransfers :: [Tx BudgetMeta] -> [KeyEntry]
-balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen
+-- balanceTransfers = undefined
-  where
+
-    go bals f@FlatTransfer {ftFrom, ftTo, ftValue = UnbalancedValue {cvValue, cvType}} =
+-- balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen
-      let balTo = M.findWithDefault 0 ftTo bals
+--   where
-          x = amtToMove balTo cvType cvValue
+--     go bals f@FlatTransfer {ftFrom, ftTo, ftValue = UnbalancedValue {cvValue, cvType}} =
-          bals' = mapAdd_ ftTo x $ mapAdd_ ftFrom (-x) bals
+--       let balTo = M.findWithDefault 0 ftTo bals
-       in (bals', f {ftValue = x})
+--           x = amtToMove balTo cvType cvValue
-    -- TODO might need to query signs to make this intuitive; as it is this will
+--           bals' = mapAdd_ ftTo x $ mapAdd_ ftFrom (-x) bals
-    -- probably work, but for credit accounts I might need to supply a negative
+--        in (bals', f {ftValue = x})
-    -- target value
+--     -- TODO might need to query signs to make this intuitive; as it is this will
-    amtToMove _ BTFixed x = x
+--     -- probably work, but for credit accounts I might need to supply a negative
-    amtToMove bal BTPercent x = -(x / 100 * bal)
+--     -- target value
-    amtToMove bal BTTarget x = x - bal
+--     amtToMove _ TFixed x = x
+--     amtToMove bal TPercent x = -(x / 100 * bal)
+--     amtToMove bal TBalance x = x - bal
 
 insertBudgetTx
   :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
-  => BalancedTransfer
+  => [InsertTx BudgetMeta]
   -> m ()
-insertBudgetTx FlatTransfer {ftFrom, ftTo, ftMeta, ftCur, ftValue, ftDesc, ftWhen} = do
+insertBudgetTx toInsert = do
-  ((sFrom, sTo), exchange) <- entryPair ftFrom ftTo ftCur ftValue
+  forM_ (groupKey (commitRHash . bmCommit) $ (\x -> (itxCommit x, x)) <$> toInsert) $
-  insertPair sFrom sTo
+    \(c, ts) -> do
-  forM_ exchange $ uncurry insertPair
+      ck <- insert $ bmCommit c
+      mapM_ (insertTx ck) ts
   where
-    insertPair from to = do
+    insertTx c InsertTx {itxDate = d, itxDescr = e, itxEntries = ss, itxCommit = BudgetMeta {bmName}} = do
-      k <- insert $ TransactionR (bmCommit ftMeta) ftWhen ftDesc
+      let anyDeferred = any (isJust . feDeferred) ss
-      insertBudgetLabel k from
+      k <- insert $ TransactionR c d e anyDeferred
-      insertBudgetLabel k to
+      mapM_ (insertBudgetLabel bmName k) ss
-    insertBudgetLabel k entry = do
+    insertBudgetLabel n k entry = do
       sk <- insertEntry k entry
-      insert_ $ BudgetLabelR sk $ bmName ftMeta
+      insert_ $ BudgetLabelR sk n
+
+-- insertBudgetTx
+--   :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
+--   => BalancedTransfer
+--   -> m ()
+-- insertBudgetTx FlatTransfer {ftFrom, ftTo, ftMeta, ftCur, ftValue, ftDesc, ftWhen} = do
+-- ((sFrom, sTo), exchange) <- entryPair ftFrom ftTo ftCur ftValue
+-- insertPair sFrom sTo
+-- forM_ exchange $ uncurry insertPair
+-- where
+--   insertPair from to = do
+--     k <- insert $ TransactionR (bmCommit ftMeta) ftWhen ftDesc
+--     insertBudgetLabel k from
+--     insertBudgetLabel k to
+--   insertBudgetLabel k entry = do
+--     sk <- insertEntry k entry
+--     insert_ $ BudgetLabelR sk $ bmName ftMeta
 
 entryPair
   :: (MonadInsertError m, MonadFinance m)
   => TaggedAcnt
   -> TaggedAcnt
-  -> BudgetCurrency
+  -> CurID
-  -> Rational
+  -> T.Text
-  -> m (EntryPair, Maybe EntryPair)
+  -> Double
-entryPair from to cur val = case cur of
+  -> m (EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational))
-  NoX curid -> (,Nothing) <$> pair curid from to val
+entryPair = entryPair_ (fmap (EntryValue TFixed) . roundPrecisionCur)
-  X Exchange {xFromCur, xToCur, xAcnt, xRate} -> do
+
-    let middle = TaggedAcnt xAcnt []
+entryPair_
-    let res1 = pair xFromCur from middle val
+  :: (MonadInsertError m, MonadFinance m)
-    let res2 = pair xToCur middle to (val * roundPrecision 3 xRate)
+  => (CurrencyPrec -> v -> v')
-    combineError res1 res2 $ \a b -> (a, Just b)
+  -> 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)
   where
-    pair curid from_ to_ v = do
+    halfEntry :: a -> [t] -> HalfEntrySet a c t v
-      let s1 = entry curid from_ (-v)
+    halfEntry a ts =
-      let s2 = entry curid to_ v
+      HalfEntrySet
-      combineError s1 s2 (,)
+        { hesPrimary = Entry {eAcnt = a, eValue = (), eComment = com, eTags = ts}
-    entry c TaggedAcnt {taAcnt, taTags} v =
+        , hesOther = []
-      resolveEntry $
+        }
-        FullEntry
+    pair cp (TaggedAcnt fa fts) (TaggedAcnt ta tts) v =
-          { feCurrency = c
+      EntrySet
-          , feEntry =
+        { esCurrency = cp
-              Entry
+        , esTotalValue = v
-                { eAcnt = taAcnt
+        , esFrom = halfEntry fa fts
-                , eValue = v
+        , esTo = halfEntry ta tts
-                , eComment = ""
+        }
-                , eTags = taTags
-                }
-          }
 
 sortAllo :: MultiAllocation v -> InsertExcept (DaySpanAllocation v)
 sortAllo a@Allocation {alloAmts = as} = do
@@ -151,7 +177,7 @@ insertIncome
   -> IntAllocations
   -> Maybe Interval
   -> Income
-  -> m [UnbalancedTransfer]
+  -> m [Tx BudgetMeta]
 insertIncome
   key
   name
@@ -197,27 +223,34 @@ insertIncome
         let (preDeductions, pre) =
               allocatePre precision gross $
                 flatPre ++ concatMap (selectAllos day) intPre
-            tax =
+        let tax =
               allocateTax precision gross preDeductions scaler $
                 flatTax ++ concatMap (selectAllos day) intTax
             aftertaxGross = gross - sumAllos (tax ++ pre)
-            post =
+        let post =
               allocatePost precision aftertaxGross $
                 flatPost ++ concatMap (selectAllos day) intPost
-            balance = aftertaxGross - sumAllos post
+        let balance = aftertaxGross - sumAllos post
-            bal =
+        -- TODO double or rational here?
-              FlatTransfer
+        primary <-
-                { ftMeta = meta
+          entryPair
-                , ftWhen = day
+            incFrom
-                , ftFrom = incFrom
+            incToBal
-                , ftCur = NoX incCurrency
+            incCurrency
-                , ftTo = incToBal
+            "balance after deductions"
-                , ftValue = UnbalancedValue BTFixed balance
+            (fromRational balance)
-                , ftDesc = "balance after deductions"
+        allos <- mapErrors (allo2Trans meta day incFrom) (pre ++ tax ++ post)
+        let bal =
+              Tx
+                { txCommit = meta
+                , txDate = day
+                , txPrimary = primary
+                , txOther = []
+                , txDescr = "balance after deductions"
                 }
-         in if balance < 0
+        if balance < 0
-              then throwError $ InsertException [IncomeError day name balance]
+          then throwError $ InsertException [IncomeError day name balance]
-              else return (bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post))
+          else return (bal : allos)
 
 periodScaler
   :: PeriodType
@@ -298,7 +331,7 @@ flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts
   where
     go Amount {amtValue, amtDesc} =
       FlatAllocation
-        { faCur = NoX alloCur
+        { faCur = alloCur
         , faTo = alloTo
         , faValue = amtValue
         , faDesc = amtDesc
@@ -311,28 +344,30 @@ selectAllos day Allocation {alloAmts, alloCur, alloTo} =
   where
     go Amount {amtValue, amtDesc} =
       FlatAllocation
-        { faCur = NoX alloCur
+        { faCur = alloCur
         , faTo = alloTo
         , faValue = amtValue
         , faDesc = amtDesc
         }
 
 allo2Trans
-  :: BudgetMeta
+  :: (MonadInsertError m, MonadFinance m)
+  => BudgetMeta
   -> Day
   -> TaggedAcnt
   -> FlatAllocation Rational
-  -> UnbalancedTransfer
+  -> m (Tx BudgetMeta)
-allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} =
+allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} = do
-  FlatTransfer
+  -- TODO double here?
-    { ftMeta = meta
+  p <- entryPair from faTo faCur faDesc (fromRational faValue)
-    , ftWhen = day
+  return
-    , ftFrom = from
+    Tx
-    , ftCur = faCur
+      { txCommit = meta
-    , ftTo = faTo
+      , txDate = day
-    , ftValue = UnbalancedValue BTFixed faValue
+      , txPrimary = p
-    , ftDesc = faDesc
+      , txOther = []
-    }
+      , txDescr = faDesc
+      }
 
 allocatePre
   :: Natural
@@ -411,46 +446,43 @@ expandTransfers
   -> T.Text
   -> Maybe Interval
   -> [BudgetTransfer]
-  -> m [UnbalancedTransfer]
+  -> m [Tx BudgetMeta]
 expandTransfers key name localInterval ts = do
   txs <-
-    fmap (L.sortOn ftWhen . concat) $
+    fmap (L.sortOn txDate . concat) $
       combineErrors $
         fmap (expandTransfer key name) ts
   case localInterval of
     Nothing -> return txs
     Just i -> do
       bounds <- liftExcept $ resolveDaySpan i
-      return $ filter (inDaySpan bounds . ftWhen) txs
+      return $ filter (inDaySpan bounds . txDate) txs
 
 expandTransfer
   :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
   => CommitRId
   -> T.Text
   -> BudgetTransfer
-  -> m [UnbalancedTransfer]
+  -> m [Tx BudgetMeta]
 expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = do
-  precision <- lookupCurrencyPrec $ initialCurrency transCurrency
+  fmap concat $ mapErrors go transAmounts
-  fmap concat $ combineErrors $ fmap (go precision) transAmounts
   where
     go
-      precision
       Amount
         { amtWhen = pat
-        , amtValue = BudgetTransferValue {btVal = v, btType = y}
+        , amtValue = TransferValue {tvVal = v, tvType = t}
         , amtDesc = desc
         } =
         withDates pat $ \day -> do
           let meta = BudgetMeta {bmCommit = key, bmName = name}
+          p <- entryPair_ (\_ x -> EntryValue t $ toRational x) transFrom transTo transCurrency desc v
           return
-            FlatTransfer
+            Tx
-              { ftMeta = meta
+              { txCommit = meta
-              , ftWhen = day
+              , txDate = day
-              , ftCur = transCurrency
+              , txPrimary = p
-              , ftFrom = transFrom
+              , txOther = []
-              , ftTo = transTo
+              , txDescr = desc
-              , ftValue = UnbalancedValue y $ roundPrecision precision v
-              , ftDesc = desc
               }
 
 withDates
@@ -468,63 +500,53 @@ withDates dp f = do
 
 -- TODO this is going to be O(n*m), which might be a problem?
 addShadowTransfers
-  :: CurrencyMap
+  :: (MonadInsertError m, MonadFinance m)
-  -> [ShadowTransfer]
+  => [ShadowTransfer]
-  -> [UnbalancedTransfer]
+  -> [Tx BudgetMeta]
-  -> InsertExcept [UnbalancedTransfer]
+  -> m [Tx BudgetMeta]
-addShadowTransfers cm ms txs =
+addShadowTransfers ms txs = mapErrors go txs
-  fmap catMaybes $
+  where
-    combineErrors $
+    go tx = do
-      fmap (uncurry (fromShadow cm)) $
+      es <- catMaybes <$> mapErrors (fromShadow tx) ms
-        [(t, m) | t <- txs, m <- ms]
+      return $ tx {txOther = es}
 
 fromShadow
-  :: CurrencyMap
+  :: (MonadInsertError m, MonadFinance m)
-  -> UnbalancedTransfer
+  => Tx BudgetMeta
   -> ShadowTransfer
-  -> InsertExcept (Maybe UnbalancedTransfer)
+  -> m (Maybe (EntrySet AcntID CurrencyPrec TagID Rational (Either Double (EntryValue Rational))))
-fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do
+fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} = do
-  res <- shadowMatches (stMatch t) tx
+  res <- liftExcept $ shadowMatches stMatch tx
-  v <- roundPrecisionCur (initialCurrency stCurrency) cm stRatio
+  es <- entryPair_ (\_ v -> Left v) stFrom stTo stCurrency stDesc stRatio
-  return $
+  return $ if not res then Nothing else Just es
-    if not res
-      then Nothing
-      else
-        Just $
-          FlatTransfer
-            { ftMeta = ftMeta tx
-            , ftWhen = ftWhen tx
-            , ftCur = stCurrency
-            , ftFrom = stFrom
-            , ftTo = stTo
-            , ftValue = UnbalancedValue stType $ v * cvValue (ftValue tx)
-            , ftDesc = stDesc
-            }
 
-shadowMatches :: TransferMatcher -> UnbalancedTransfer -> InsertExcept Bool
+shadowMatches :: TransferMatcher -> Tx BudgetMeta -> InsertExcept Bool
-shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do
+shadowMatches TransferMatcher {tmFrom, tmTo, tmDate} Tx {txPrimary, txDate} = do
-  valRes <- valMatches tmVal $ cvValue $ ftValue tx
+  -- 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
   return $
-    memberMaybe (taAcnt $ ftFrom tx) tmFrom
+    memberMaybe (eAcnt $ hesPrimary $ esFrom txPrimary) tmFrom
-      && memberMaybe (taAcnt $ ftTo tx) tmTo
+      && memberMaybe (eAcnt $ hesPrimary $ esTo txPrimary) tmTo
-      && maybe True (`dateMatches` ftWhen tx) tmDate
+      && maybe True (`dateMatches` txDate) tmDate
-      && valRes
   where
+    -- && valRes
+
     memberMaybe x AcntSet {asList, asInclude} =
       (if asInclude then id else not) $ x `elem` asList
 
 --------------------------------------------------------------------------------
 -- random
 
-initialCurrency :: BudgetCurrency -> CurID
+-- initialCurrency :: TransferCurrency -> CurID
-initialCurrency (NoX c) = c
+-- initialCurrency (NoX c) = c
-initialCurrency (X Exchange {xFromCur = c}) = c
+-- initialCurrency (X Exchange {xFromCur = c}) = c
 
 alloAcnt :: Allocation w v -> AcntID
 alloAcnt = taAcnt . alloTo
 
 data UnbalancedValue = UnbalancedValue
-  { cvType :: !BudgetTransferType
+  { cvType :: !TransferType
   , cvValue :: !Rational
   }
   deriving (Show)
@@ -533,75 +555,77 @@ data UnbalancedValue = UnbalancedValue
 -- in the history algorithm, which will entail resolving the budget currency
 -- stuff earlier in the chain, and preloading multiple entries into this thing
 -- before balancing.
-type UnbalancedTransfer = FlatTransfer UnbalancedValue
+-- type UnbalancedTransfer = FlatTransfer UnbalancedValue
 
-ubt2tx :: UnbalancedTransfer -> Tx [EntrySet AcntID CurID TagID Rational] BudgetMeta
+-- ubt2tx :: UnbalancedTransfer -> Tx BudgetMeta
-ubt2tx
+-- ubt2tx
-  FlatTransfer
+--   FlatTransfer
-    { ftFrom
+--     { ftFrom
-    , ftTo
+--     , ftTo
-    , ftValue
+--     , ftValue
-    , ftWhen
+--     , ftWhen
-    , ftDesc
+--     , ftDesc
-    , ftMeta
+--     , ftMeta
-    , ftCur
+--     , ftCur
-    } =
+--     } =
-    Tx
+--     Tx
-      { txDescr = ftDesc
+--       { txDescr = ftDesc
-      , txDate = ftWhen
+--       , txDate = ftWhen
-      , txEntries = entries ftCur
+--       , txPrimary = p
-      , txCommit = ftMeta
+--       , txOther = maybeToList os
-      }
+--       , txCommit = ftMeta
-    where
+--       }
-      entries (NoX curid) = [pair curid ftFrom ftTo ftValue]
+--     where
-      entries (X Exchange {xFromCur, xToCur, xAcnt, xRate}) =
+--       (p, os) = entries ftCur
-        let middle = TaggedAcnt xAcnt []
+--       entries (NoX curid) = (pair curid ftFrom ftTo ftValue, Nothing)
-            p1 = pair xFromCur ftFrom middle ftValue
+--       entries (X Exchange {xFromCur, xToCur, xAcnt, xRate}) =
-            p2 = pair xToCur middle ftTo (ftValue * roundPrecision 3 xRate)
+--         let middle = TaggedAcnt xAcnt []
-         in [p1, p2]
+--             p1 = pair xFromCur ftFrom middle ftValue
-      pair c (TaggedAcnt fa fts) (TaggedAcnt ta tts) v =
+--             p2 = pair xToCur middle ftTo (ftValue * roundPrecision 3 xRate)
-        EntrySet
+--          in (p1, Just p2)
-          { esTotalValue = v
+--       pair c (TaggedAcnt fa fts) (TaggedAcnt ta tts) v =
-          , esCurrency = c
+--         EntrySet
-          , esFrom =
+--           { esTotalValue = v
-              HalfEntrySet
+--           , esCurrency = c
-                { hesPrimary =
+--           , esFrom =
-                    Entry
+--               HalfEntrySet
-                      { eValue = ()
+--                 { hesPrimary =
-                      , eComment = ""
+--                     Entry
-                      , eAcnt = fa
+--                       { eValue = ()
-                      , eTags = fts
+--                       , eComment = ""
-                      }
+--                       , eAcnt = fa
-                , hesOther = []
+--                       , eTags = fts
-                }
+--                       }
-          , esTo =
+--                 , hesOther = []
-              HalfEntrySet
+--                 }
-                { hesPrimary =
+--           , esTo =
-                    Entry
+--               HalfEntrySet
-                      { eValue = ()
+--                 { hesPrimary =
-                      , eComment = ""
+--                     Entry
-                      , eAcnt = ta
+--                       { eValue = ()
-                      , eTags = tts
+--                       , eComment = ""
-                      }
+--                       , eAcnt = ta
-                , hesOther = []
+--                       , eTags = tts
-                }
+--                       }
-          }
+--                 , hesOther = []
+--                 }
+--           }
 
-type BalancedTransfer = FlatTransfer Rational
+-- type BalancedTransfer = FlatTransfer Rational
 
-data FlatTransfer v = FlatTransfer
+-- data FlatTransfer v = FlatTransfer
-  { ftFrom :: !TaggedAcnt
+--   { ftFrom :: !TaggedAcnt
-  , ftTo :: !TaggedAcnt
+--   , ftTo :: !TaggedAcnt
-  , ftValue :: !v
+--   , ftValue :: !v
-  , ftWhen :: !Day
+--   , ftWhen :: !Day
-  , ftDesc :: !T.Text
+--   , ftDesc :: !T.Text
-  , ftMeta :: !BudgetMeta
+--   , ftMeta :: !BudgetMeta
-  , ftCur :: !BudgetCurrency
+--   , ftCur :: !TransferCurrency
-  }
+--   }
-  deriving (Show)
+--   deriving (Show)
 
 data BudgetMeta = BudgetMeta
-  { bmCommit :: !CommitRId
+  { bmCommit :: !CommitR
   , bmName :: !T.Text
   }
   deriving (Show)
@@ -622,6 +646,6 @@ data FlatAllocation v = FlatAllocation
   { faValue :: !v
   , faDesc :: !T.Text
   , faTo :: !TaggedAcnt
-  , faCur :: !BudgetCurrency
+  , faCur :: !CurID
   }
   deriving (Functor, Show)

lib/Internal/History.hs

@@ -3,6 +3,7 @@ module Internal.History
   , readHistTransfer
   , insertHistory
   , splitHistory
+  , balanceTxs
   )
 where
 
@@ -75,7 +76,7 @@ splitHistory = partitionEithers . fmap go
 
 insertHistory
   :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
-  => [EntryBin]
+  => [EntryBin CommitR]
   -> m ()
 insertHistory hs = do
   (toUpdate, toInsert) <- balanceTxs hs
@@ -95,17 +96,17 @@ txPair
   -> AcntID
   -> AcntID
   -> CurrencyPrec
-  -> Double
+  -> TransferValue
   -> T.Text
   -> Tx CommitR
-txPair commit day from to cur val desc =
+txPair commit day from to cur (TransferValue t v) desc =
   Tx
     { txDescr = desc
     , txDate = day
     , txCommit = commit
     , txPrimary =
         EntrySet
-          { esTotalValue = -(roundPrecisionCur cur val)
+          { esTotalValue = EntryValue t $ toRational v
           , esCurrency = cur
           , esFrom = HalfEntrySet {hesPrimary = entry from, hesOther = []}
           , esTo = HalfEntrySet {hesPrimary = entry to, hesOther = []}
@@ -125,7 +126,7 @@ txPair commit day from to cur val desc =
 -- resolveTx t@Tx {txEntries = ss} =
 --   (\kss -> t {txEntries = kss}) <$> mapErrors resolveEntry ss
 
-insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m ()
+insertTx :: MonadSqlQuery m => CommitRId -> InsertTx CommitR -> m ()
 insertTx c InsertTx {itxDate = d, itxDescr = e, itxEntries = ss} = do
   let anyDeferred = any (isJust . feDeferred) ss
   k <- insert $ TransactionR c d e anyDeferred
@@ -348,8 +349,8 @@ matchNonDates ms = go ([], [], initZipper ms)
 
 balanceTxs
   :: (MonadInsertError m, MonadFinance m)
-  => [EntryBin]
+  => [EntryBin a]
-  -> m ([UEBalanced], [InsertTx])
+  -> m ([UEBalanced], [InsertTx a])
 balanceTxs ebs =
   first concat . partitionEithers . catMaybes
     <$> evalStateT (mapErrors go $ L.sortOn binDate ebs) M.empty
@@ -358,22 +359,27 @@ balanceTxs ebs =
     go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do
       modify $ mapAdd_ (reAcnt, reCurrency) reValue
       return Nothing
-    go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate}) =
+    go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate}) = do
-      let res0 = balanceEntrySet (\_ _ v -> return v) txPrimary
+      e <- balanceEntrySet primaryBalance txPrimary
-          resN = mapErrors (balanceEntrySet primaryBalance) txOther
+      -- TODO this logic is really stupid, I'm balancing the total twice; fix
-       in combineError res0 resN $ \e es ->
+      -- will likely entail making a separate data structure for txs derived
-            -- TODO repacking a Tx into almost the same record seems stupid
+      -- from transfers vs statements
-            Just $
+      let etot = sum $ eValue . feEntry <$> filter ((< 0) . feIndex) e
-              Right $
+      es <- mapErrors (balanceEntrySet (secondaryBalance etot)) txOther
-                InsertTx
+      let tx =
-                  { itxDescr = txDescr
+            InsertTx
-                  , itxDate = txDate
+              { itxDescr = txDescr
-                  , itxEntries = concat $ e : es
+              , itxDate = txDate
-                  , itxCommit = txCommit
+              , itxEntries = concat $ e : es
-                  }
+              , itxCommit = txCommit
+              }
+      return $ Just $ Right tx
     primaryBalance Entry {eAcnt} c (EntryValue t v) = findBalance eAcnt c t v
+    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 :: EntryBin a -> Day
 binDate (ToUpdate UpdateEntrySet {utDate}) = utDate
 binDate (ToRead ReadEntry {reDate}) = reDate
 binDate (ToInsert Tx {txDate}) = txDate

lib/Internal/Types/Dhall.hs

@@ -34,7 +34,6 @@ makeHaskellTypesWith
   , MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher"
   , MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter"
   , MultipleConstructors "LinkedEntryNumGetter" "(./dhall/Types.dhall).LinkedEntryNumGetter"
-  , MultipleConstructors "TransferCurrency" "(./dhall/Types.dhall).TransferCurrency"
   , MultipleConstructors "TransferType" "(./dhall/Types.dhall).TransferType"
   , MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod"
   , MultipleConstructors "PeriodType" "(./dhall/Types.dhall).PeriodType"
@@ -55,8 +54,7 @@ makeHaskellTypesWith
   , SingleConstructor "TransferMatcher" "TransferMatcher" "(./dhall/Types.dhall).TransferMatcher.Type"
   , SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer"
   , -- , SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income.Type"
-    SingleConstructor "Exchange" "Exchange" "(./dhall/Types.dhall).Exchange"
+    SingleConstructor "Field" "Field" "(./dhall/Types.dhall).Field"
-  , SingleConstructor "Field" "Field" "(./dhall/Types.dhall).Field"
   , SingleConstructor "Entry" "Entry" "(./dhall/Types.dhall).Entry"
   , SingleConstructor "PretaxValue" "PretaxValue" "(./dhall/Types.dhall).PretaxValue"
   , SingleConstructor "TaxBracket" "TaxBracket" "(./dhall/Types.dhall).TaxBracket"
@@ -97,8 +95,6 @@ deriveProduct
   , "DateMatcher"
   , "ValMatcher"
   , "YMDMatcher"
-  , "TransferCurrency"
-  , "Exchange"
   , "EntryNumGetter"
   , "LinkedNumGetter"
   , "LinkedEntryNumGetter"
@@ -183,7 +179,7 @@ deriving instance Ord DatePat
 deriving instance Hashable DatePat
 
 type BudgetTransfer =
-  Transfer TaggedAcnt TransferCurrency DatePat TransferValue
+  Transfer TaggedAcnt CurID DatePat TransferValue
 
 deriving instance Hashable BudgetTransfer
 
@@ -272,10 +268,6 @@ deriving instance (Show w, Show v) => Show (Amount w v)
 
 deriving instance (Eq w, Eq v) => Eq (Amount w v)
 
-deriving instance Hashable Exchange
-
-deriving instance Hashable TransferCurrency
-
 data Allocation w v = Allocation
   { alloTo :: TaggedAcnt
   , alloAmts :: [Amount w v]
@@ -428,7 +420,7 @@ type AcntID = T.Text
 
 type TagID = T.Text
 
-type HistTransfer = Transfer AcntID CurID DatePat Double
+type HistTransfer = Transfer AcntID CurID DatePat TransferValue
 
 deriving instance Generic HistTransfer
 

lib/Internal/Types/Main.hs

@@ -121,10 +121,10 @@ data UpdateEntrySet = UpdateEntrySet
   , utTotalValue :: !Rational
   }
 
-data EntryBin
+data EntryBin a
   = ToUpdate UpdateEntrySet
   | ToRead ReadEntry
-  | ToInsert (Tx CommitR)
+  | ToInsert (Tx a)
 
 data InsertEntry a c t = InsertEntry
   { feCurrency :: !c
@@ -221,17 +221,17 @@ data EntrySet a c t v v' = EntrySet
 data Tx k = Tx
   { txDescr :: !T.Text
   , txDate :: !Day
-  , txPrimary :: !(EntrySet AcntID CurrencyPrec TagID Rational Rational)
+  , txPrimary :: !(EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational))
-  , txOther :: ![EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational)]
+  , txOther :: ![EntrySet AcntID CurrencyPrec TagID Rational (Either Double (EntryValue Rational))]
   , txCommit :: !k
   }
   deriving (Generic)
 
-data InsertTx = InsertTx
+data InsertTx a = InsertTx
   { itxDescr :: !T.Text
   , itxDate :: !Day
   , itxEntries :: ![InsertEntry AccountRId CurrencyRId TagRId]
-  , itxCommit :: !CommitR
+  , itxCommit :: !a
   }
   deriving (Generic)
 

lib/Internal/Utils.hs

@@ -327,7 +327,7 @@ toTx
         , txCommit = ()
         , txPrimary =
             EntrySet
-              { esTotalValue = roundPrecisionCur cur $ tgScale * fromRational trAmount
+              { esTotalValue = EntryValue TFixed $ roundPrecisionCur cur $ tgScale * fromRational trAmount
               , esCurrency = cur
               , esFrom = f
               , esTo = t
@@ -347,7 +347,7 @@ resolveSubGetter
   :: MonadFinance m
   => TxRecord
   -> TxSubGetter
-  -> InsertExceptT m (EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational))
+  -> InsertExceptT m (EntrySet AcntID CurrencyPrec TagID Rational (Either Double (EntryValue Rational)))
 resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
   m <- askDBState kmCurrency
   cur <- liftInner $ resolveCurrency m r tsgCurrency
@@ -356,7 +356,7 @@ resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
   let valRes = liftInner $ fmap (roundPrecisionCur cur) <$> resolveValue r tsgValue
   liftInner $ combineError3 fromRes toRes valRes $ \f t v ->
     EntrySet
-      { esTotalValue = v
+      { esTotalValue = Right v
       , esCurrency = cur
       , esFrom = f
       , esTo = t