ADD local budget interval

lib/Internal/Database/Ops.hs

@@ -19,8 +19,15 @@ import Database.Esqueleto.Experimental ((==.), (^.))
 import qualified Database.Esqueleto.Experimental as E
 import Database.Esqueleto.Internal.Internal (SqlSelect)
 import Database.Persist.Monad
--- import Database.Persist.Sql hiding (delete, runMigration, (==.), (||.))
+import Database.Persist.Sqlite hiding
-import Database.Persist.Sqlite hiding (delete, deleteWhere, insert, insertKey, runMigration, (==.), (||.))
+  ( delete
+  , deleteWhere
+  , insert
+  , insertKey
+  , runMigration
+  , (==.)
+  , (||.)
+  )
 import GHC.Err
 import Internal.Types
 import Internal.Utils

lib/Internal/Insert.hs

@@ -95,6 +95,22 @@ expandMDYPat lower upper (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = r
 dayToWeekday :: Day -> Int
 dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7
 
+askDays
+  :: (MonadFinance m, MonadInsertError m)
+  => DatePat
+  -> Maybe Interval
+  -> m [Day]
+askDays dp i = do
+  globalBounds <- askDBState kmBudgetInterval
+  case i of
+    Just i' -> do
+      localBounds <- liftExcept $ resolveBounds i'
+      let bounds = intersectBounds globalBounds localBounds
+      maybe (return []) expand bounds
+    Nothing -> expand globalBounds
+  where
+    expand bs = liftExcept $ expandDatePat bs dp
+
 withDates
   :: (MonadSqlQuery m, MonadFinance m, MonadInsertError m)
   => DatePat
@@ -105,15 +121,13 @@ withDates dp f = do
   days <- liftExcept $ expandDatePat bounds dp
   combineErrors $ fmap f days
 
-foldDates
+foldDays
-  :: (MonadSqlQuery m, MonadFinance m, MonadInsertError m)
+  :: MonadInsertError m
-  => DatePat
+  => (Day -> Day -> m a)
   -> Day
-  -> (Day -> Day -> m a)
+  -> [Day]
   -> m [a]
-foldDates dp start f = do
+foldDays f start days =
-  bounds <- askDBState kmBudgetInterval
-  days <- liftExcept $ expandDatePat bounds dp
   combineErrors $
     snd $
       L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days
@@ -145,11 +159,12 @@ insertBudget
     , bgtPretax
     , bgtTax
     , bgtPosttax
+    , bgtInterval
     } =
     whenHash CTBudget b () $ \key -> do
       intAllos <- combineError3 pre_ tax_ post_ (,,)
-      let res1 = mapErrors (insertIncome key bgtLabel intAllos) bgtIncomes
+      let res1 = mapErrors (insertIncome key bgtLabel intAllos bgtInterval) bgtIncomes
-      let res2 = expandTransfers key bgtLabel bgtTransfers
+      let res2 = expandTransfers key bgtLabel bgtInterval bgtTransfers
       txs <- combineError (concat <$> res1) res2 (++)
       m <- askDBState kmCurrency
       shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs
@@ -160,7 +175,7 @@ insertBudget
       post_ = sortAllos bgtPosttax
       sortAllos = liftExcept . combineErrors . fmap sortAllo
 
-type BoundAllocation = Allocation (Day, Day)
+type BoundAllocation = Allocation Bounds
 
 type IntAllocations =
   ( [BoundAllocation PretaxValue]
@@ -180,7 +195,7 @@ sortAllo a@Allocation {alloAmts = as} = do
       res <- case xs of
         [] -> resolveBounds start
         (y : _) -> resolveBounds_ (intStart $ amtWhen y) start
-      foldBounds (x {amtWhen = expandBounds res} : acc) xs
+      foldBounds (x {amtWhen = res} : acc) xs
 
 -- TODO this is going to be O(n*m), which might be a problem?
 addShadowTransfers
@@ -209,35 +224,35 @@ fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, st
         Just $
           -- TODO does this actually share the same metadata as the "parent" tx?
           FlatTransfer
-            { cbtMeta = cbtMeta tx
+            { ftMeta = ftMeta tx
-            , cbtWhen = cbtWhen tx
+            , ftWhen = ftWhen tx
-            , cbtCur = stCurrency
+            , ftCur = stCurrency
-            , cbtFrom = stFrom
+            , ftFrom = stFrom
-            , cbtTo = stTo
+            , ftTo = stTo
-            , cbtValue = UnbalancedValue stType $ v * cvValue (cbtValue tx)
+            , ftValue = UnbalancedValue stType $ v * cvValue (ftValue tx)
-            , cbtDesc = stDesc
+            , ftDesc = stDesc
             }
 
 shadowMatches :: TransferMatcher -> UnbalancedTransfer -> InsertExcept Bool
 shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do
-  valRes <- valMatches tmVal $ cvValue $ cbtValue tx
+  valRes <- valMatches tmVal $ cvValue $ ftValue tx
   return $
-    memberMaybe (taAcnt $ cbtFrom tx) tmFrom
+    memberMaybe (taAcnt $ ftFrom tx) tmFrom
-      && memberMaybe (taAcnt $ cbtTo tx) tmTo
+      && memberMaybe (taAcnt $ ftTo tx) tmTo
-      && maybe True (`dateMatches` cbtWhen tx) tmDate
+      && maybe True (`dateMatches` ftWhen tx) tmDate
       && valRes
   where
     memberMaybe x AcntSet {asList, asInclude} =
       (if asInclude then id else not) $ x `elem` asList
 
 balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer]
-balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn cbtWhen
+balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen
   where
-    go bals f@FlatTransfer {cbtFrom, cbtTo, cbtValue = UnbalancedValue {cvValue, cvType}} =
+    go bals f@FlatTransfer {ftFrom, ftTo, ftValue = UnbalancedValue {cvValue, cvType}} =
-      let balTo = M.findWithDefault 0 cbtTo bals
+      let balTo = M.findWithDefault 0 ftTo bals
           x = amtToMove balTo cvType cvValue
-          bals' = mapAdd_ cbtTo x $ mapAdd_ cbtFrom (-x) bals
+          bals' = mapAdd_ ftTo x $ mapAdd_ ftFrom (-x) bals
-       in (bals', f {cbtValue = x})
+       in (bals', f {ftValue = x})
     -- TODO might need to query signs to make this intuitive; as it is this will
     -- probably work, but for credit accounts I might need to supply a negative
     -- target value
@@ -255,13 +270,13 @@ data BudgetMeta = BudgetMeta
   deriving (Show)
 
 data FlatTransfer v = FlatTransfer
-  { cbtFrom :: !TaggedAcnt
+  { ftFrom :: !TaggedAcnt
-  , cbtTo :: !TaggedAcnt
+  , ftTo :: !TaggedAcnt
-  , cbtValue :: !v
+  , ftValue :: !v
-  , cbtWhen :: !Day
+  , ftWhen :: !Day
-  , cbtDesc :: !T.Text
+  , ftDesc :: !T.Text
-  , cbtMeta :: !BudgetMeta
+  , ftMeta :: !BudgetMeta
-  , cbtCur :: !BudgetCurrency
+  , ftCur :: !BudgetCurrency
   }
   deriving (Show)
 
@@ -276,16 +291,18 @@ type UnbalancedTransfer = FlatTransfer UnbalancedValue
 type BalancedTransfer = FlatTransfer Rational
 
 insertIncome
-  :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
+  :: (MonadInsertError m, MonadFinance m)
   => CommitRId
   -> T.Text
   -> IntAllocations
+  -> Maybe Interval
   -> Income
   -> m [UnbalancedTransfer]
 insertIncome
   key
   name
   (intPre, intTax, intPost)
+  localInterval
   Income
     { incWhen
     , incCurrency
@@ -304,7 +321,8 @@ insertIncome
     -- TODO this will scan the interval allocations fully each time
     -- iteration which is a total waste, but the fix requires turning this
     -- loop into a fold which I don't feel like doing now :(
-    res <- foldDates incWhen start (allocate precision gross)
+    days <- askDays incWhen localInterval
+    res <- foldDays (allocate precision gross) start days
     return $ concat res
     where
       start = fromGregorian' $ pStart incPayPeriod
@@ -330,13 +348,13 @@ insertIncome
             balance = aftertaxGross - sumAllos post
             bal =
               FlatTransfer
-                { cbtMeta = meta
+                { ftMeta = meta
-                , cbtWhen = day
+                , ftWhen = day
-                , cbtFrom = incFrom
+                , ftFrom = incFrom
-                , cbtCur = NoX incCurrency
+                , ftCur = NoX incCurrency
-                , cbtTo = incToBal
+                , ftTo = incToBal
-                , cbtValue = UnbalancedValue BTFixed balance
+                , ftValue = UnbalancedValue BTFixed balance
-                , cbtDesc = "balance after deductions"
+                , ftDesc = "balance after deductions"
                 }
          in if balance < 0
               then throwError $ InsertException [IncomeError day name balance]
@@ -404,13 +422,13 @@ allo2Trans
   -> UnbalancedTransfer
 allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} =
   FlatTransfer
-    { cbtMeta = meta
+    { ftMeta = meta
-    , cbtWhen = day
+    , ftWhen = day
-    , cbtFrom = from
+    , ftFrom = from
-    , cbtCur = faCur
+    , ftCur = faCur
-    , cbtTo = faTo
+    , ftTo = faTo
-    , cbtValue = UnbalancedValue BTFixed faValue
+    , ftValue = UnbalancedValue BTFixed faValue
-    , cbtDesc = faDesc
+    , ftDesc = faDesc
     }
 
 allocateTax
@@ -501,12 +519,19 @@ expandTransfers
   :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
   => CommitRId
   -> T.Text
+  -> Maybe Interval
   -> [BudgetTransfer]
   -> m [UnbalancedTransfer]
-expandTransfers key name ts =
+expandTransfers key name localInterval ts = do
-  fmap (L.sortOn cbtWhen . concat) $
+  txs <-
-    combineErrors $
+    fmap (L.sortOn ftWhen . concat) $
-      fmap (expandTransfer key name) ts
+      combineErrors $
+        fmap (expandTransfer key name) ts
+  case localInterval of
+    Nothing -> return txs
+    Just i -> do
+      bounds <- liftExcept $ resolveBounds i
+      return $ filter (inBounds bounds . ftWhen) txs
 
 initialCurrency :: BudgetCurrency -> CurID
 initialCurrency (NoX c) = c
@@ -533,28 +558,28 @@ expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFro
           let meta = BudgetMeta {bmCommit = key, bmName = name}
           return
             FlatTransfer
-              { cbtMeta = meta
+              { ftMeta = meta
-              , cbtWhen = day
+              , ftWhen = day
-              , cbtCur = transCurrency
+              , ftCur = transCurrency
-              , cbtFrom = transFrom
+              , ftFrom = transFrom
-              , cbtTo = transTo
+              , ftTo = transTo
-              , cbtValue = UnbalancedValue y $ roundPrecision precision v
+              , ftValue = UnbalancedValue y $ roundPrecision precision v
-              , cbtDesc = desc
+              , ftDesc = desc
               }
 
 insertBudgetTx :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) => BalancedTransfer -> m ()
-insertBudgetTx FlatTransfer {cbtFrom, cbtTo, cbtMeta, cbtCur, cbtValue, cbtDesc, cbtWhen} = do
+insertBudgetTx FlatTransfer {ftFrom, ftTo, ftMeta, ftCur, ftValue, ftDesc, ftWhen} = do
-  ((sFrom, sTo), exchange) <- splitPair cbtFrom cbtTo cbtCur cbtValue
+  ((sFrom, sTo), exchange) <- splitPair ftFrom ftTo ftCur ftValue
   insertPair sFrom sTo
   forM_ exchange $ uncurry insertPair
   where
     insertPair from to = do
-      k <- insert $ TransactionR (bmCommit cbtMeta) cbtWhen cbtDesc
+      k <- insert $ TransactionR (bmCommit ftMeta) ftWhen ftDesc
       insertBudgetLabel k from
       insertBudgetLabel k to
     insertBudgetLabel k split = do
       sk <- insertSplit k split
-      insert_ $ BudgetLabelR sk $ bmName cbtMeta
+      insert_ $ BudgetLabelR sk $ bmName ftMeta
 
 type SplitPair = (KeySplit, KeySplit)
 
@@ -646,7 +671,7 @@ insertHistTransfer
 readHistStmt :: (MonadUnliftIO m, MonadFinance m) => Statement -> m (Maybe (CommitR, [KeyTx]))
 readHistStmt i = whenHash_ CTImport i $ do
   bs <- readImport i
-  bounds <- expandBounds <$> askDBState kmStatementInterval
+  bounds <- askDBState kmStatementInterval
   liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs
 
 insertHistStmt :: (MonadSqlQuery m) => CommitR -> [KeyTx] -> m ()

lib/Internal/Types.hs

@@ -200,6 +200,7 @@ data Budget = Budget
   , bgtPosttax :: [MultiAllocation PosttaxValue]
   , bgtTransfers :: [BudgetTransfer]
   , bgtShadowTransfers :: [ShadowTransfer]
+  , bgtInterval :: !(Maybe Interval)
   }
 
 deriving instance Hashable PretaxValue

lib/Internal/Utils.hs

@@ -8,6 +8,7 @@ module Internal.Utils
   , fromGregorian'
   , resolveBounds
   , resolveBounds_
+  , intersectBounds
   , liftInner
   , liftExceptT
   , liftExcept
@@ -161,14 +162,26 @@ compareDate (In md offset) x = do
 fromGregorian' :: Gregorian -> Day
 fromGregorian' = uncurry3 fromGregorian . gregTup
 
--- TODO misleading name
+inBounds :: Bounds -> Day -> Bool
-inBounds :: (Day, Day) -> Day -> Bool
+inBounds bs = withinDays (expandBounds bs)
-inBounds (d0, d1) x = d0 <= x && x < d1
+
+withinDays :: (Day, Day) -> Day -> Bool
+withinDays (d0, d1) x = d0 <= x && x < d1
 
 resolveBounds :: Interval -> InsertExcept Bounds
 resolveBounds i@Interval {intStart = s} =
   resolveBounds_ (s {gYear = gYear s + 50}) i
 
+-- TODO not DRY
+intersectBounds :: Bounds -> Bounds -> Maybe Bounds
+intersectBounds a b =
+  if b' > a' then Nothing else Just (a', fromIntegral $ diffDays b' a' - 1)
+  where
+    (a0, a1) = expandBounds a
+    (b0, b1) = expandBounds b
+    a' = max a0 a1
+    b' = min b0 b1
+
 resolveBounds_ :: Gregorian -> Interval -> InsertExcept Bounds
 resolveBounds_ def Interval {intStart = s, intEnd = e} =
   case fromGregorian' <$> e of