WIP mostly unify history and budget transfer pipelines

dhall/Types.dhall

@@ -714,11 +714,19 @@ let Transfer =
         , transAmounts : List (Amount w v)
         }
 
+let TaggedAcnt =
+    {-
+    An account with a tag
+    -}
+      { Type = { taAcnt : AcntID, taTags : List TagID }
+      , default.taTags = [] : List TagID
+      }
+
 let HistTransfer =
     {-
     A manually specified historical transfer
     -}
-      Transfer AcntID CurID DatePat TransferValue.Type
+      Transfer TaggedAcnt.Type CurID DatePat TransferValue.Type
 
 let Statement =
     {-
@@ -755,12 +763,6 @@ let History =
     -}
       < HistTransfer : HistTransfer | HistStatement : Statement >
 
-let TaggedAcnt =
-    {-
-    An account with a tag
-    -}
-      { taAcnt : AcntID, taTags : List TagID }
-
 let Allocation =
     {-
     How to allocate a given budget stream. This can be thought of as a Transfer
@@ -768,7 +770,7 @@ let Allocation =
     -}
       \(w : Type) ->
       \(v : Type) ->
-        { alloTo : TaggedAcnt
+        { alloTo : TaggedAcnt.Type
         , alloAmts : List (Amount w v)
         , alloCur :
             {-TODO allow exchanges here-}
@@ -958,13 +960,13 @@ let Income =
               This must be an income AcntID, and is the only place income
               accounts may be specified in the entire budget.
               -}
-              TaggedAcnt
+              TaggedAcnt.Type
           , incToBal :
               {-
               The account to which to send the remainder of the income stream
               (if any) after all allocations have been applied.
               -}
-              TaggedAcnt
+              TaggedAcnt.Type
           }
       , default =
         { incPretax = [] : List (SingleAllocation PretaxValue)
@@ -1034,12 +1036,12 @@ let ShadowTransfer =
           {-
           Source of this transfer
           -}
-          TaggedAcnt
+          TaggedAcnt.Type
       , stTo :
           {-
           Destination of this transfer.
           -}
-          TaggedAcnt
+          TaggedAcnt.Type
       , stCurrency :
           {-
           Currency of this transfer.
@@ -1070,7 +1072,7 @@ let BudgetTransfer =
     {-
     A manually specified transaction for a budget
     -}
-      Transfer TaggedAcnt CurID DatePat TransferValue.Type
+      HistTransfer
 
 let Budget =
     {-

lib/Internal/Budget.hs

@@ -3,6 +3,7 @@ module Internal.Budget (readBudget) where
 import Control.Monad.Except
 import Data.Foldable
 import Internal.Database
+import Internal.History
 import Internal.Types.Main
 import Internal.Utils
 import RIO hiding (to)
@@ -39,9 +40,14 @@ readBudget
     , bgtInterval
     } =
     eitherHash CTBudget b return $ \key -> do
+      spanRes <- getSpan
+      case spanRes of
+        Nothing -> return []
+        Just budgetSpan -> do
           (intAllos, _) <- combineError intAlloRes acntRes (,)
-      let res1 = mapErrors (readIncome key bgtLabel intAllos bgtInterval) bgtIncomes
+          let tc = BudgetCommit key bgtLabel
-      let res2 = expandTransfers key bgtLabel bgtInterval bgtTransfers
+          let res1 = mapErrors (readIncome tc intAllos budgetSpan) bgtIncomes
+          let res2 = expandTransfers tc (Just budgetSpan) bgtTransfers
           txs <- combineError (concat <$> res1) res2 (++)
           shadow <- addShadowTransfers bgtShadowTransfers txs
           return $ txs ++ shadow
@@ -56,43 +62,13 @@ readBudget
         (alloAcnt <$> bgtPretax)
           ++ (alloAcnt <$> bgtTax)
           ++ (alloAcnt <$> bgtPosttax)
-
+      getSpan = do
-entryPair
+        globalSpan <- askDBState kmBudgetInterval
-  :: (MonadInsertError m, MonadFinance m)
+        case bgtInterval of
-  => TaggedAcnt
+          Nothing -> return $ Just globalSpan
-  -> TaggedAcnt
+          Just bi -> do
-  -> CurID
+            localSpan <- liftExcept $ resolveDaySpan bi
-  -> T.Text
+            return $ intersectDaySpan globalSpan localSpan
-  -> Double
-  -> m (EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational))
-entryPair = entryPair_ (fmap (EntryValue TFixed) . roundPrecisionCur)
-
-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)
-  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
-        , esFrom = halfEntry fa fts
-        , esTo = halfEntry ta tts
-        }
 
 sortAllo :: MultiAllocation v -> InsertExcept (DaySpanAllocation v)
 sortAllo a@Allocation {alloAmts = as} = do
@@ -115,17 +91,15 @@ sortAllo a@Allocation {alloAmts = as} = do
 -- loop into a fold which I don't feel like doing now :(
 readIncome
   :: (MonadInsertError m, MonadFinance m)
-  => CommitR
+  => TxCommit
-  -> T.Text
   -> IntAllocations
-  -> Maybe Interval
+  -> DaySpan
   -> Income
   -> m [Tx TxCommit]
 readIncome
-  key
+  tc
-  name
   (intPre, intTax, intPost)
-  localInterval
+  ds
   Income
     { incWhen
     , incCurrency
@@ -152,10 +126,9 @@ readIncome
             ++ (alloAcnt <$> incTaxes)
             ++ (alloAcnt <$> incPosttax)
       precRes = lookupCurrencyPrec incCurrency
-      dayRes = askDays incWhen localInterval
+      dayRes = liftExcept $ expandDatePat ds incWhen
       start = fromGregorian' $ pStart incPayPeriod
       pType' = pType incPayPeriod
-      meta = BudgetCommit key name
       flatPre = concatMap flattenAllo incPretax
       flatTax = concatMap flattenAllo incTaxes
       flatPost = concatMap flattenAllo incPosttax
@@ -182,17 +155,18 @@ readIncome
             incCurrency
             "balance after deductions"
             (fromRational balance)
-        allos <- mapErrors (allo2Trans meta day incFrom) (pre ++ tax ++ post)
+        allos <- mapErrors (allo2Trans tc day incFrom) (pre ++ tax ++ post)
         let bal =
               Tx
-                { txCommit = meta
+                { txCommit = tc
                 , txDate = day
                 , txPrimary = primary
                 , txOther = []
                 , txDescr = "balance after deductions"
                 }
+        -- TODO use real name here
         if balance < 0
-          then throwError $ InsertException [IncomeError day name balance]
+          then throwError $ InsertException [IncomeError day "" balance]
           else return (bal : allos)
 
 periodScaler
@@ -383,61 +357,6 @@ allocatePost precision aftertax = fmap (fmap go)
 --------------------------------------------------------------------------------
 -- Standalone Transfer
 
-expandTransfers
-  :: (MonadInsertError m, MonadFinance m)
-  => CommitR
-  -> T.Text
-  -> Maybe Interval
-  -> [BudgetTransfer]
-  -> m [Tx TxCommit]
-expandTransfers key name localInterval ts = do
-  txs <-
-    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 . txDate) txs
-
-expandTransfer
-  :: (MonadInsertError m, MonadFinance m)
-  => CommitR
-  -> T.Text
-  -> BudgetTransfer
-  -> m [Tx TxCommit]
-expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} =
-  concat <$> mapErrors go transAmounts
-  where
-    go
-      Amount
-        { amtWhen = pat
-        , amtValue = TransferValue {tvVal = v, tvType = t}
-        , amtDesc = desc
-        } =
-        withDates pat $ \day -> do
-          let meta = BudgetCommit key name
-          p <- entryPair_ (\_ x -> EntryValue t $ toRational x) transFrom transTo transCurrency desc v
-          return
-            Tx
-              { txCommit = meta
-              , txDate = day
-              , txPrimary = p
-              , txOther = []
-              , txDescr = desc
-              }
-
-withDates
-  :: (MonadFinance m, MonadInsertError m)
-  => DatePat
-  -> (Day -> m a)
-  -> m [a]
-withDates dp f = do
-  bounds <- askDBState kmBudgetInterval
-  days <- liftExcept $ expandDatePat bounds dp
-  combineErrors $ fmap f days
-
 --------------------------------------------------------------------------------
 -- shadow transfers
 

lib/Internal/History.hs

@@ -5,6 +5,9 @@ module Internal.History
   , splitHistory
   , balanceTxs
   , updateTx
+  , entryPair_
+  , expandTransfers
+  , entryPair
   )
 where
 
@@ -30,24 +33,11 @@ import qualified RIO.Vector as V
 -- TODO unify this with the transfer system I use in the budget now
 readHistTransfer
   :: (MonadInsertError m, MonadFinance m)
-  => HistTransfer
+  => PairedTransfer
   -> m (Either CommitR [Tx TxCommit])
-readHistTransfer
+readHistTransfer ht = eitherHash CTManual ht return $ \c -> do
-  m@Transfer
-    { transFrom = from
-    , transTo = to
-    , transCurrency = u
-    , transAmounts = amts
-    } =
-    eitherHash CTManual m return $ \c -> do
   bounds <- askDBState kmStatementInterval
-      let curRes = lookupCurrency u
+  expandTransfer (HistoryCommit c) (Just bounds) ht
-      let go Amount {amtWhen, amtValue, amtDesc} = do
-            let dayRes = liftExcept $ expandDatePat bounds amtWhen
-            (days, cur) <- combineError dayRes curRes (,)
-            let tx day = txPair c day from to cur amtValue amtDesc
-            return $ fmap tx days
-      concat <$> mapErrors go amts
 
 readHistStmt
   :: (MonadUnliftIO m, MonadFinance m)
@@ -59,7 +49,7 @@ readHistStmt root i = eitherHash CTImport i return $ \c -> do
   bounds <- askDBState kmStatementInterval
   return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = HistoryCommit c}) bs
 
-splitHistory :: [History] -> ([HistTransfer], [Statement])
+splitHistory :: [History] -> ([PairedTransfer], [Statement])
 splitHistory = partitionEithers . fmap go
   where
     go (HistTransfer x) = Left x
@@ -98,39 +88,126 @@ updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. unStaticValue
 --------------------------------------------------------------------------------
 -- low-level transaction stuff
 
--- TODO tags here?
+expandTransfers
-txPair
+  :: (MonadInsertError m, MonadFinance m)
-  :: CommitR
+  => TxCommit
-  -> Day
+  -> Maybe DaySpan
-  -> AcntID
+  -> [PairedTransfer]
-  -> AcntID
+  -> m [Tx TxCommit]
-  -> CurrencyPrec
+expandTransfers tc localInterval ts =
-  -> TransferValue
+  fmap (L.sortOn txDate . concat) $
-  -> T.Text
+    combineErrors $
-  -> Tx TxCommit
+      fmap (expandTransfer tc localInterval) ts
-txPair commit day from to cur (TransferValue t v) desc =
+
-  Tx
+expandTransfer
-    { txDescr = desc
+  :: (MonadInsertError m, MonadFinance m)
-    , txDate = day
+  => TxCommit
-    , txCommit = HistoryCommit commit
+  -> Maybe DaySpan
-    , txPrimary =
+  -> PairedTransfer
-        EntrySet
+  -> m [Tx TxCommit]
-          { esTotalValue = EntryValue t $ toRational v
+expandTransfer tc ds Transfer {transAmounts, transTo, transCurrency, transFrom} = do
-          , esCurrency = cur
+  txs <- concat <$> mapErrors go transAmounts
-          , esFrom = HalfEntrySet {hesPrimary = entry from, hesOther = []}
+  return $ case ds of
-          , esTo = HalfEntrySet {hesPrimary = entry to, hesOther = []}
+    Nothing -> txs
-          }
+    Just bounds -> filter (inDaySpan bounds . txDate) txs
-    , txOther = []
-    }
   where
-    entry a =
+    go
-      Entry
+      Amount
-        { eAcnt = a
+        { amtWhen = pat
-        , eValue = ()
+        , amtValue = TransferValue {tvVal = v, tvType = t}
-        , eComment = ""
+        , amtDesc = desc
-        , eTags = []
+        } =
+        withDates pat $ \day -> do
+          p <- entryPair_ (\_ x -> EntryValue t $ toRational x) transFrom transTo transCurrency desc v
+          return
+            Tx
+              { txCommit = tc
+              , txDate = day
+              , txPrimary = p
+              , txOther = []
+              , txDescr = desc
               }
 
+entryPair
+  :: (MonadInsertError m, MonadFinance m)
+  => TaggedAcnt
+  -> TaggedAcnt
+  -> CurID
+  -> T.Text
+  -> Double
+  -> m (EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational))
+entryPair = entryPair_ (fmap (EntryValue TFixed) . roundPrecisionCur)
+
+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)
+  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
+        , esFrom = halfEntry fa fts
+        , esTo = halfEntry ta tts
+        }
+
+withDates
+  :: (MonadFinance m, MonadInsertError m)
+  => DatePat
+  -> (Day -> m a)
+  -> m [a]
+withDates dp f = do
+  bounds <- askDBState kmBudgetInterval
+  days <- liftExcept $ expandDatePat bounds dp
+  combineErrors $ fmap f days
+
+-- -- TODO tags here?
+-- txPair
+--   :: CommitR
+--   -> Day
+--   -> AcntID
+--   -> AcntID
+--   -> CurrencyPrec
+--   -> TransferValue
+--   -> T.Text
+--   -> Tx TxCommit
+-- txPair commit day from to cur (TransferValue t v) desc =
+--   Tx
+--     { txDescr = desc
+--     , txDate = day
+--     , txCommit = HistoryCommit commit
+--     , txPrimary =
+--         EntrySet
+--           { esTotalValue = EntryValue t $ toRational v
+--           , esCurrency = cur
+--           , esFrom = HalfEntrySet {hesPrimary = entry from, hesOther = []}
+--           , esTo = HalfEntrySet {hesPrimary = entry to, hesOther = []}
+--           }
+--     , txOther = []
+--     }
+--   where
+--     entry a =
+--       Entry
+--         { eAcnt = a
+--         , eValue = ()
+--         , eComment = ""
+--         , eTags = []
+--         }
+
 -- resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx CommitR -> m (KeyTx CommitR)
 -- resolveTx t@Tx {txEntries = ss} =
 --   (\kss -> t {txEntries = kss}) <$> mapErrors resolveEntry ss

lib/Internal/Types/Dhall.hs

@@ -40,7 +40,7 @@ makeHaskellTypesWith
   , SingleConstructor "LinkedNumGetter" "LinkedNumGetter" "(./dhall/Types.dhall).LinkedNumGetter.Type"
   , SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
   , SingleConstructor "Tag" "Tag" "(./dhall/Types.dhall).Tag"
-  , SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt"
+  , SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt.Type"
   , SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
   , SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
   , SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval"
@@ -178,14 +178,13 @@ deriving instance Ord DatePat
 
 deriving instance Hashable DatePat
 
-type BudgetTransfer =
+type PairedTransfer = Transfer TaggedAcnt CurID DatePat TransferValue
-  Transfer TaggedAcnt CurID DatePat TransferValue
 
-deriving instance Hashable BudgetTransfer
+deriving instance Hashable PairedTransfer
 
-deriving instance Generic BudgetTransfer
+deriving instance Generic PairedTransfer
 
-deriving instance FromDhall BudgetTransfer
+deriving instance FromDhall PairedTransfer
 
 data Budget = Budget
   { bgtLabel :: Text
@@ -193,7 +192,7 @@ data Budget = Budget
   , bgtPretax :: [MultiAllocation PretaxValue]
   , bgtTax :: [MultiAllocation TaxValue]
   , bgtPosttax :: [MultiAllocation PosttaxValue]
-  , bgtTransfers :: [BudgetTransfer]
+  , bgtTransfers :: [PairedTransfer]
   , bgtShadowTransfers :: [ShadowTransfer]
   , bgtInterval :: !(Maybe Interval)
   }
@@ -420,16 +419,8 @@ type AcntID = T.Text
 
 type TagID = T.Text
 
-type HistTransfer = Transfer AcntID CurID DatePat TransferValue
-
-deriving instance Generic HistTransfer
-
-deriving instance Hashable HistTransfer
-
-deriving instance FromDhall HistTransfer
-
 data History
-  = HistTransfer !HistTransfer
+  = HistTransfer !PairedTransfer
   | HistStatement !Statement
   deriving (Eq, Generic, Hashable, FromDhall)
 

lib/Internal/Utils.hs

@@ -274,6 +274,7 @@ intersectDaySpan a b =
 
 resolveDaySpan_ :: Gregorian -> Interval -> InsertExcept DaySpan
 resolveDaySpan_ def Interval {intStart = s, intEnd = e} =
+  -- TODO the default isn't checked here :/
   case fromGregorian' <$> e of
     Nothing -> return $ toDaySpan_ $ fromGregorian' def
     Just e_