REF split history and budget

app/Main.hs

@@ -8,9 +8,10 @@ import Control.Monad.Logger
 import Control.Monad.Reader
 import qualified Data.Text.IO as TI
 import Database.Persist.Monad
+import Internal.Budget
 import Internal.Config
 import Internal.Database.Ops
-import Internal.Insert
+import Internal.History
 import Internal.Types.Main
 import Internal.Utils
 import Options.Applicative

budget.cabal

@@ -25,9 +25,10 @@ source-repository head
 
 library
   exposed-modules:
+      Internal.Budget
       Internal.Config
       Internal.Database.Ops
-      Internal.Insert
+      Internal.History
       Internal.Statement
       Internal.Types.Database
       Internal.Types.Dhall

lib/Internal/Budget.hs

@@ -1,16 +1,8 @@
-module Internal.Insert
+module Internal.Budget (insertBudget) where
-  ( insertBudget
-  , splitHistory
-  , insertHistTransfer
-  , readHistStmt
-  , insertHistStmt
-  )
-where
 
 import Control.Monad.Except
-import Data.Hashable
 import Database.Persist.Monad
-import Internal.Statement
+import Internal.Database.Ops
 import Internal.Types.Main
 import Internal.Utils
 import RIO hiding (to)
@@ -20,132 +12,6 @@ import qualified RIO.NonEmpty as NE
 import qualified RIO.Text as T
 import RIO.Time
 
---------------------------------------------------------------------------------
--- intervals
-
-expandDatePat :: Bounds -> DatePat -> InsertExcept [Day]
-expandDatePat b (Cron cp) = expandCronPat b cp
-expandDatePat i (Mod mp) = return $ expandModPat mp i
-
-expandModPat :: ModPat -> Bounds -> [Day]
-expandModPat ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r} bs =
-  takeWhile (<= upper) $
-    (`addFun` start) . (* b')
-      <$> maybe id (take . fromIntegral) r [0 ..]
-  where
-    (lower, upper) = expandBounds bs
-    start = maybe lower fromGregorian' s
-    b' = fromIntegral b
-    addFun = case u of
-      Day -> addDays
-      Week -> addDays . (* 7)
-      Month -> addGregorianMonthsClip
-      Year -> addGregorianYearsClip
-
-expandCronPat :: Bounds -> CronPat -> InsertExcept [Day]
-expandCronPat b CronPat {cpYear, cpMonth, cpDay, cpWeekly} =
-  combineError3 yRes mRes dRes $ \ys ms ds ->
-    filter validWeekday $
-      mapMaybe (uncurry3 toDay) $
-        takeWhile (\((y, _), m, d) -> (y, m, d) <= (yb1, mb1, db1)) $
-          dropWhile (\((y, _), m, d) -> (y, m, d) < (yb0, mb0, db0)) $
-            [(y, m, d) | y <- (\y -> (y, isLeapYear y)) <$> ys, m <- ms, d <- ds]
-  where
-    yRes = case cpYear of
-      Nothing -> return [yb0 .. yb1]
-      Just pat -> do
-        ys <- expandMDYPat (fromIntegral yb0) (fromIntegral yb1) pat
-        return $ dropWhile (< yb0) $ fromIntegral <$> ys
-    mRes = expandMD 12 cpMonth
-    dRes = expandMD 31 cpDay
-    (s, e) = expandBounds b
-    (yb0, mb0, db0) = toGregorian s
-    (yb1, mb1, db1) = toGregorian $ addDays (-1) e
-    expandMD lim =
-      fmap (fromIntegral <$>)
-        . maybe (return [1 .. lim]) (expandMDYPat 1 lim)
-    expandW (OnDay x) = [fromEnum x]
-    expandW (OnDays xs) = fromEnum <$> xs
-    ws = maybe [] expandW cpWeekly
-    validWeekday = if null ws then const True else \day -> dayToWeekday day `elem` ws
-    toDay (y, leap) m d
-      | m == 2 && (not leap && d > 28 || leap && d > 29) = Nothing
-      | m `elem` [4, 6, 9, 11] && d > 30 = Nothing
-      | otherwise = Just $ fromGregorian y m d
-
-expandMDYPat :: Natural -> Natural -> MDYPat -> InsertExcept [Natural]
-expandMDYPat lower upper (Single x) = return [x | lower <= x && x <= upper]
-expandMDYPat lower upper (Multi xs) = return $ dropWhile (<= lower) $ takeWhile (<= upper) xs
-expandMDYPat lower upper (After x) = return [max lower x .. upper]
-expandMDYPat lower upper (Before x) = return [lower .. min upper x]
-expandMDYPat lower upper (Between x y) = return [max lower x .. min upper y]
-expandMDYPat lower upper (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = r})
-  | b < 1 = throwError $ InsertException [PatternError s b r ZeroLength]
-  | otherwise = do
-      k <- limit r
-      return $ dropWhile (<= lower) $ takeWhile (<= k) [s + i * b | i <- [0 ..]]
-  where
-    limit Nothing = return upper
-    limit (Just n)
-      -- this guard not only produces the error for the user but also protects
-      -- from an underflow below it
-      | n < 1 = throwError $ InsertException [PatternError s b r ZeroRepeats]
-      | otherwise = return $ min (s + b * (n - 1)) upper
-
-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
-  -> (Day -> m a)
-  -> m [a]
-withDates dp f = do
-  bounds <- askDBState kmBudgetInterval
-  days <- liftExcept $ expandDatePat bounds dp
-  combineErrors $ fmap f days
-
-foldDays
-  :: MonadInsertError m
-  => (Day -> Day -> m a)
-  -> Day
-  -> [Day]
-  -> m [a]
-foldDays f start days =
-  combineErrors $
-    snd $
-      L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days
-
---------------------------------------------------------------------------------
--- budget
-
--- each budget (designated at the top level by a 'name') is processed in the
--- following steps
--- 1. expand all transactions given the desired date range and date patterns for
---    each directive in the budget
--- 2. sort all transactions by date
--- 3. propagate all balances forward, and while doing so assign values to each
---    transaction (some of which depend on the 'current' balance of the
---    target account)
--- 4. assign shadow transactions (TODO)
--- 5. insert all transactions
-
 insertBudget
   :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
   => Budget
@@ -175,75 +41,6 @@ insertBudget
       post_ = sortAllos bgtPosttax
       sortAllos = liftExcept . combineErrors . fmap sortAllo
 
-type BoundAllocation = Allocation Bounds
-
-type IntAllocations =
-  ( [BoundAllocation PretaxValue]
-  , [BoundAllocation TaxValue]
-  , [BoundAllocation PosttaxValue]
-  )
-
--- TODO this should actually error if there is no ultimate end date?
-sortAllo :: MultiAllocation v -> InsertExcept (BoundAllocation v)
-sortAllo a@Allocation {alloAmts = as} = do
-  bs <- foldBounds [] $ L.sortOn amtWhen as
-  return $ a {alloAmts = reverse bs}
-  where
-    foldBounds acc [] = return acc
-    foldBounds acc (x : xs) = do
-      let start = amtWhen x
-      res <- case xs of
-        [] -> resolveBounds start
-        (y : _) -> resolveBounds_ (intStart $ amtWhen y) start
-      foldBounds (x {amtWhen = res} : acc) xs
-
--- TODO this is going to be O(n*m), which might be a problem?
-addShadowTransfers
-  :: CurrencyMap
-  -> [ShadowTransfer]
-  -> [UnbalancedTransfer]
-  -> InsertExcept [UnbalancedTransfer]
-addShadowTransfers cm ms txs =
-  fmap catMaybes $
-    combineErrors $
-      fmap (uncurry (fromShadow cm)) $
-        [(t, m) | t <- txs, m <- ms]
-
-fromShadow
-  :: CurrencyMap
-  -> UnbalancedTransfer
-  -> ShadowTransfer
-  -> InsertExcept (Maybe UnbalancedTransfer)
-fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do
-  res <- shadowMatches (stMatch t) tx
-  v <- roundPrecisionCur (initialCurrency stCurrency) cm stRatio
-  return $
-    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 {tmFrom, tmTo, tmDate, tmVal} tx = do
-  valRes <- valMatches tmVal $ cvValue $ ftValue tx
-  return $
-    memberMaybe (taAcnt $ ftFrom tx) tmFrom
-      && memberMaybe (taAcnt $ ftTo tx) tmTo
-      && 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 ftWhen
   where
@@ -259,35 +56,71 @@ balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen
     amtToMove bal BTPercent x = -(x / 100 * bal)
     amtToMove bal BTTarget x = x - bal
 
+-- TODO this seems too general for this module
 mapAdd_ :: (Ord k, Num v) => k -> v -> M.Map k v -> M.Map k v
 mapAdd_ k v = M.alter (maybe (Just v) (Just . (+ v))) k
 
-data BudgetMeta = BudgetMeta
+insertBudgetTx
-  { bmCommit :: !CommitRId
+  :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
-  , bmName :: !T.Text
+  => 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 split = do
+      sk <- insertSplit k split
+      insert_ $ BudgetLabelR sk $ bmName ftMeta
+
+entryPair
+  :: (MonadInsertError m, MonadFinance m)
+  => TaggedAcnt
+  -> TaggedAcnt
+  -> BudgetCurrency
+  -> Rational
+  -> m (SplitPair, Maybe SplitPair)
+entryPair from to cur val = case cur of
+  NoX curid -> (,Nothing) <$> pair curid from to val
+  X Exchange {xFromCur, xToCur, xAcnt, xRate} -> do
+    let middle = TaggedAcnt xAcnt []
+    let res1 = pair xFromCur from middle val
+    let res2 = pair xToCur middle to (val * roundPrecision 3 xRate)
+    combineError res1 res2 $ \a b -> (a, Just b)
+  where
+    pair curid from_ to_ v = do
+      let s1 = split curid from_ (-v)
+      let s2 = split curid to_ v
+      combineError s1 s2 (,)
+    split c TaggedAcnt {taAcnt, taTags} v =
+      resolveSplit $
+        Entry
+          { eAcnt = taAcnt
+          , eValue = v
+          , eComment = ""
+          , eCurrency = c
+          , eTags = taTags
           }
-  deriving (Show)
 
-data FlatTransfer v = FlatTransfer
+sortAllo :: MultiAllocation v -> InsertExcept (DaySpanAllocation v)
-  { ftFrom :: !TaggedAcnt
+sortAllo a@Allocation {alloAmts = as} = do
-  , ftTo :: !TaggedAcnt
+  bs <- foldSpan [] $ L.sortOn amtWhen as
-  , ftValue :: !v
+  return $ a {alloAmts = reverse bs}
-  , ftWhen :: !Day
+  where
-  , ftDesc :: !T.Text
+    foldSpan acc [] = return acc
-  , ftMeta :: !BudgetMeta
+    foldSpan acc (x : xs) = do
-  , ftCur :: !BudgetCurrency
+      let start = amtWhen x
-  }
+      res <- case xs of
-  deriving (Show)
+        [] -> resolveDaySpan start
+        (y : _) -> resolveDaySpan_ (intStart $ amtWhen y) start
+      foldSpan (x {amtWhen = res} : acc) xs
 
-data UnbalancedValue = UnbalancedValue
+--------------------------------------------------------------------------------
-  { cvType :: !BudgetTransferType
+-- Income
-  , cvValue :: !Rational
-  }
-  deriving (Show)
-
-type UnbalancedTransfer = FlatTransfer UnbalancedValue
-
-type BalancedTransfer = FlatTransfer Rational
 
 insertIncome
   :: (MonadInsertError m, MonadFinance m)
@@ -359,8 +192,6 @@ insertIncome
               then throwError $ InsertException [IncomeError day name balance]
               else return (bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post))
 
-type PeriodScaler = Natural -> Double -> Double
-
 -- TODO we probably don't need to check for 1/0 each time
 periodScaler
   :: PeriodType
@@ -398,21 +229,58 @@ workingDays wds start end
     wds' = L.sort $ (\x -> diff (fromWeekday x) startDay) <$> L.nub wds
     diff a b = fromIntegral $ mod (fromEnum a - fromEnum b) 7
 
-allocatePre
+foldDays
-  :: Natural
+  :: MonadInsertError m
-  -> Rational
+  => (Day -> Day -> m a)
-  -> [FlatAllocation PretaxValue]
+  -> Day
-  -> (M.Map T.Text Rational, [FlatAllocation Rational])
+  -> [Day]
-allocatePre precision gross = L.mapAccumR go M.empty
+  -> m [a]
+foldDays f start days =
+  combineErrors $
+    snd $
+      L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days
+
+checkAcntType
+  :: (MonadInsertError m, MonadFinance m)
+  => AcntType
+  -> AcntID
+  -> m AcntID
+checkAcntType t = checkAcntTypes (t :| [])
+
+checkAcntTypes
+  :: (MonadInsertError m, MonadFinance m)
+  => NE.NonEmpty AcntType
+  -> AcntID
+  -> m AcntID
+checkAcntTypes ts i = go =<< lookupAccountType i
   where
-    go m f@FlatAllocation {faValue} =
+    go t
-      let c = preCategory faValue
+      | t `L.elem` ts = return i
-          p = preValue faValue
+      | otherwise = throwError $ InsertException [AccountError i ts]
-          v =
+
-            if prePercent faValue
+flattenAllo :: SingleAllocation v -> [FlatAllocation v]
-              then (roundPrecision 3 p / 100) * gross
+flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts
-              else roundPrecision precision p
+  where
-       in (mapAdd_ c v m, f {faValue = v})
+    go Amount {amtValue, amtDesc} =
+      FlatAllocation
+        { faCur = NoX alloCur
+        , faTo = alloTo
+        , faValue = amtValue
+        , faDesc = amtDesc
+        }
+
+-- ASSUME allocations are sorted
+selectAllos :: Day -> DaySpanAllocation v -> [FlatAllocation v]
+selectAllos day Allocation {alloAmts, alloCur, alloTo} =
+  go <$> filter ((`inDaySpan` day) . amtWhen) alloAmts
+  where
+    go Amount {amtValue, amtDesc} =
+      FlatAllocation
+        { faCur = NoX alloCur
+        , faTo = alloTo
+        , faValue = amtValue
+        , faDesc = amtDesc
+        }
 
 allo2Trans
   :: BudgetMeta
@@ -431,6 +299,22 @@ allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} =
     , ftDesc = faDesc
     }
 
+allocatePre
+  :: Natural
+  -> Rational
+  -> [FlatAllocation PretaxValue]
+  -> (M.Map T.Text Rational, [FlatAllocation Rational])
+allocatePre precision gross = L.mapAccumR go M.empty
+  where
+    go m f@FlatAllocation {faValue} =
+      let c = preCategory faValue
+          p = preValue faValue
+          v =
+            if prePercent faValue
+              then (roundPrecision 3 p / 100) * gross
+              else roundPrecision precision p
+       in (mapAdd_ c v m, f {faValue = v})
+
 allocateTax
   :: Natural
   -> Rational
@@ -451,19 +335,6 @@ allocateTax precision gross preDeds f = fmap (fmap go)
               let taxDed = roundPrecision precision $ f precision tpDeductible
                in foldBracket f precision (agi - taxDed) tpBrackets
 
-allocatePost
-  :: Natural
-  -> Rational
-  -> [FlatAllocation PosttaxValue]
-  -> [FlatAllocation Rational]
-allocatePost precision aftertax = fmap (fmap go)
-  where
-    go PosttaxValue {postValue, postPercent} =
-      let v = postValue
-       in if postPercent
-            then aftertax * roundPrecision 3 v / 100
-            else roundPrecision precision v
-
 -- | Compute effective tax percentage of a bracket
 -- The algorithm can be thought of in three phases:
 -- 1. Find the highest tax bracket by looping backward until the AGI is less
@@ -483,37 +354,21 @@ foldBracket f precision agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit
           p = roundPrecision 3 tbPercent / 100
        in if remain >= l then (acc + p * (remain - l), l) else a
 
-data FlatAllocation v = FlatAllocation
+allocatePost
-  { faValue :: !v
+  :: Natural
-  , faDesc :: !T.Text
+  -> Rational
-  , faTo :: !TaggedAcnt
+  -> [FlatAllocation PosttaxValue]
-  , faCur :: !BudgetCurrency
+  -> [FlatAllocation Rational]
-  }
+allocatePost precision aftertax = fmap (fmap go)
-  deriving (Functor, Show)
-
-flattenAllo :: SingleAllocation v -> [FlatAllocation v]
-flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts
   where
-    go Amount {amtValue, amtDesc} =
+    go PosttaxValue {postValue, postPercent} =
-      FlatAllocation
+      let v = postValue
-        { faCur = NoX alloCur
+       in if postPercent
-        , faTo = alloTo
+            then aftertax * roundPrecision 3 v / 100
-        , faValue = amtValue
+            else roundPrecision precision v
-        , faDesc = amtDesc
-        }
 
--- ASSUME allocations are sorted
+--------------------------------------------------------------------------------
-selectAllos :: Day -> BoundAllocation v -> [FlatAllocation v]
+-- Transfer
-selectAllos day Allocation {alloAmts, alloCur, alloTo} =
-  go <$> filter ((`inBounds` day) . amtWhen) alloAmts
-  where
-    go Amount {amtValue, amtDesc} =
-      FlatAllocation
-        { faCur = NoX alloCur
-        , faTo = alloTo
-        , faValue = amtValue
-        , faDesc = amtDesc
-        }
 
 expandTransfers
   :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
@@ -530,12 +385,8 @@ expandTransfers key name localInterval ts = do
   case localInterval of
     Nothing -> return txs
     Just i -> do
-      bounds <- liftExcept $ resolveBounds i
+      bounds <- liftExcept $ resolveDaySpan i
-      return $ filter (inBounds bounds . ftWhen) txs
+      return $ filter (inDaySpan bounds . ftWhen) txs
-
-initialCurrency :: BudgetCurrency -> CurID
-initialCurrency (NoX c) = c
-initialCurrency (X Exchange {xFromCur = c}) = c
 
 expandTransfer
   :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
@@ -567,248 +418,116 @@ expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFro
               , ftDesc = desc
               }
 
-insertBudgetTx :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) => BalancedTransfer -> m ()
+withDates
-insertBudgetTx FlatTransfer {ftFrom, ftTo, ftMeta, ftCur, ftValue, ftDesc, ftWhen} = do
+  :: (MonadSqlQuery m, MonadFinance m, MonadInsertError m)
-  ((sFrom, sTo), exchange) <- splitPair ftFrom ftTo ftCur ftValue
+  => DatePat
-  insertPair sFrom sTo
+  -> (Day -> m a)
-  forM_ exchange $ uncurry insertPair
+  -> m [a]
+withDates dp f = do
+  bounds <- askDBState kmBudgetInterval
+  days <- liftExcept $ expandDatePat bounds dp
+  combineErrors $ fmap f days
+
+--------------------------------------------------------------------------------
+-- shadow transfers
+
+-- TODO this is going to be O(n*m), which might be a problem?
+addShadowTransfers
+  :: CurrencyMap
+  -> [ShadowTransfer]
+  -> [UnbalancedTransfer]
+  -> InsertExcept [UnbalancedTransfer]
+addShadowTransfers cm ms txs =
+  fmap catMaybes $
+    combineErrors $
+      fmap (uncurry (fromShadow cm)) $
+        [(t, m) | t <- txs, m <- ms]
+
+fromShadow
+  :: CurrencyMap
+  -> UnbalancedTransfer
+  -> ShadowTransfer
+  -> InsertExcept (Maybe UnbalancedTransfer)
+fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do
+  res <- shadowMatches (stMatch t) tx
+  v <- roundPrecisionCur (initialCurrency stCurrency) cm stRatio
+  return $
+    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 {tmFrom, tmTo, tmDate, tmVal} tx = do
+  valRes <- valMatches tmVal $ cvValue $ ftValue tx
+  return $
+    memberMaybe (taAcnt $ ftFrom tx) tmFrom
+      && memberMaybe (taAcnt $ ftTo tx) tmTo
+      && maybe True (`dateMatches` ftWhen tx) tmDate
+      && valRes
   where
-    insertPair from to = do
+    memberMaybe x AcntSet {asList, asInclude} =
-      k <- insert $ TransactionR (bmCommit ftMeta) ftWhen ftDesc
+      (if asInclude then id else not) $ x `elem` asList
-      insertBudgetLabel k from
+
-      insertBudgetLabel k to
+--------------------------------------------------------------------------------
-    insertBudgetLabel k split = do
+-- random
-      sk <- insertSplit k split
+
-      insert_ $ BudgetLabelR sk $ bmName ftMeta
+initialCurrency :: BudgetCurrency -> CurID
+initialCurrency (NoX c) = c
+initialCurrency (X Exchange {xFromCur = c}) = c
+
+data UnbalancedValue = UnbalancedValue
+  { cvType :: !BudgetTransferType
+  , cvValue :: !Rational
+  }
+  deriving (Show)
+
+type UnbalancedTransfer = FlatTransfer UnbalancedValue
+
+type BalancedTransfer = FlatTransfer Rational
+
+data FlatTransfer v = FlatTransfer
+  { ftFrom :: !TaggedAcnt
+  , ftTo :: !TaggedAcnt
+  , ftValue :: !v
+  , ftWhen :: !Day
+  , ftDesc :: !T.Text
+  , ftMeta :: !BudgetMeta
+  , ftCur :: !BudgetCurrency
+  }
+  deriving (Show)
+
+data BudgetMeta = BudgetMeta
+  { bmCommit :: !CommitRId
+  , bmName :: !T.Text
+  }
+  deriving (Show)
+
+type IntAllocations =
+  ( [DaySpanAllocation PretaxValue]
+  , [DaySpanAllocation TaxValue]
+  , [DaySpanAllocation PosttaxValue]
+  )
+
+type DaySpanAllocation = Allocation DaySpan
 
 type SplitPair = (KeySplit, KeySplit)
 
-splitPair
+type PeriodScaler = Natural -> Double -> Double
-  :: (MonadInsertError m, MonadFinance m)
+
-  => TaggedAcnt
+data FlatAllocation v = FlatAllocation
-  -> TaggedAcnt
+  { faValue :: !v
-  -> BudgetCurrency
+  , faDesc :: !T.Text
-  -> Rational
+  , faTo :: !TaggedAcnt
-  -> m (SplitPair, Maybe SplitPair)
+  , faCur :: !BudgetCurrency
-splitPair from to cur val = case cur of
-  NoX curid -> (,Nothing) <$> pair curid from to val
-  X Exchange {xFromCur, xToCur, xAcnt, xRate} -> do
-    let middle = TaggedAcnt xAcnt []
-    let res1 = pair xFromCur from middle val
-    let res2 = pair xToCur middle to (val * roundPrecision 3 xRate)
-    combineError res1 res2 $ \a b -> (a, Just b)
-  where
-    pair curid from_ to_ v = do
-      let s1 = split curid from_ (-v)
-      let s2 = split curid to_ v
-      combineError s1 s2 (,)
-    split c TaggedAcnt {taAcnt, taTags} v =
-      resolveSplit $
-        Entry
-          { eAcnt = taAcnt
-          , eValue = v
-          , eComment = ""
-          , eCurrency = c
-          , eTags = taTags
   }
-
+  deriving (Functor, Show)
-checkAcntType
-  :: (MonadInsertError m, MonadFinance m)
-  => AcntType
-  -> AcntID
-  -> m AcntID
-checkAcntType t = checkAcntTypes (t :| [])
-
-checkAcntTypes
-  :: (MonadInsertError m, MonadFinance m)
-  => NE.NonEmpty AcntType
-  -> AcntID
-  -> m AcntID
-checkAcntTypes ts i = go =<< lookupAccountType i
-  where
-    go t
-      | t `L.elem` ts = return i
-      | otherwise = throwError $ InsertException [AccountError i ts]
-
---------------------------------------------------------------------------------
--- statements
-
-splitHistory :: [History] -> ([HistTransfer], [Statement])
-splitHistory = partitionEithers . fmap go
-  where
-    go (HistTransfer x) = Left x
-    go (HistStatement x) = Right x
-
--- insertStatement
---   :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m)
---   => History
---   -> m ()
--- insertStatement (HistTransfer m) = liftIOExceptT $ insertManual m
--- insertStatement (HistStatement i) = insertImport i
-
-insertHistTransfer
-  :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
-  => HistTransfer
-  -> m ()
-insertHistTransfer
-  m@Transfer
-    { transFrom = from
-    , transTo = to
-    , transCurrency = u
-    , transAmounts = amts
-    } = do
-    whenHash CTManual m () $ \c -> do
-      bounds <- askDBState kmStatementInterval
-      let precRes = lookupCurrencyPrec u
-      let go Amount {amtWhen, amtValue, amtDesc} = do
-            let dayRes = liftExcept $ expandDatePat bounds amtWhen
-            (days, precision) <- combineError dayRes precRes (,)
-            let tx day = txPair day from to u (roundPrecision precision amtValue) amtDesc
-            keys <- combineErrors $ fmap tx days
-            mapM_ (insertTx c) keys
-      void $ combineErrors $ fmap go amts
-
-readHistStmt :: (MonadUnliftIO m, MonadFinance m) => Statement -> m (Maybe (CommitR, [KeyTx]))
-readHistStmt i = whenHash_ CTImport i $ do
-  bs <- readImport i
-  bounds <- askDBState kmStatementInterval
-  liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs
-
-insertHistStmt :: (MonadSqlQuery m) => CommitR -> [KeyTx] -> m ()
-insertHistStmt c ks = do
-  ck <- insert c
-  mapM_ (insertTx ck) ks
-
--- insertImport
---   :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m)
---   => Statement
---   -> m ()
--- insertImport i = whenHash CTImport i () $ \c -> do
---   -- TODO this isn't efficient, the whole file will be read and maybe no
---   -- transactions will be desired
---   bs <- readImport i
---   bounds <- expandBounds <$> askDBState kmStatementInterval
---   keys <- liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs
---   mapM_ (insertTx c) keys
-
---------------------------------------------------------------------------------
--- low-level transaction stuff
-
--- TODO tags here?
-txPair
-  :: (MonadInsertError m, MonadFinance m)
-  => Day
-  -> AcntID
-  -> AcntID
-  -> CurID
-  -> Rational
-  -> T.Text
-  -> m KeyTx
-txPair day from to cur val desc = resolveTx tx
-  where
-    split a v =
-      Entry
-        { eAcnt = a
-        , eValue = v
-        , eComment = ""
-        , eCurrency = cur
-        , eTags = []
-        }
-    tx =
-      Tx
-        { txDescr = desc
-        , txDate = day
-        , txSplits = [split from (-val), split to val]
-        }
-
-resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx
-resolveTx t@Tx {txSplits = ss} =
-  fmap (\kss -> t {txSplits = kss}) $
-    combineErrors $
-      fmap resolveSplit ss
-
-resolveSplit :: (MonadInsertError m, MonadFinance m) => BalSplit -> m KeySplit
-resolveSplit s@Entry {eAcnt, eCurrency, eValue, eTags} = do
-  let aRes = lookupAccountKey eAcnt
-  let cRes = lookupCurrencyKey eCurrency
-  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
-        { eAcnt = aid
-        , eCurrency = cid
-        , eValue = eValue * fromIntegral (sign2Int sign)
-        , eTags = tags
-        }
-
-insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m ()
-insertTx c Tx {txDate = d, txDescr = e, txSplits = ss} = do
-  k <- insert $ TransactionR c d e
-  mapM_ (insertSplit k) ss
-
-insertSplit :: MonadSqlQuery m => TransactionRId -> KeySplit -> m SplitRId
-insertSplit t Entry {eAcnt, eCurrency, eValue, eComment, eTags} = do
-  k <- insert $ SplitR t eCurrency eAcnt eComment eValue
-  mapM_ (insert_ . TagRelationR k) eTags
-  return k
-
-lookupAccount :: (MonadInsertError m, MonadFinance m) => AcntID -> m (AccountRId, AcntSign, AcntType)
-lookupAccount = lookupFinance AcntField kmAccount
-
-lookupAccountKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m AccountRId
-lookupAccountKey = fmap fstOf3 . lookupAccount
-
-lookupAccountSign :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntSign
-lookupAccountSign = fmap sndOf3 . lookupAccount
-
-lookupAccountType :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntType
-lookupAccountType = fmap thdOf3 . lookupAccount
-
-lookupCurrency :: (MonadInsertError m, MonadFinance m) => T.Text -> m (CurrencyRId, Natural)
-lookupCurrency = lookupFinance CurField kmCurrency
-
-lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m CurrencyRId
-lookupCurrencyKey = fmap fst . lookupCurrency
-
-lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => AcntID -> m Natural
-lookupCurrencyPrec = fmap snd . lookupCurrency
-
-lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId
-lookupTag = lookupFinance TagField kmTag
-
-lookupFinance
-  :: (MonadInsertError m, MonadFinance m)
-  => SplitIDType
-  -> (DBState -> M.Map T.Text a)
-  -> T.Text
-  -> m a
-lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f
-
--- TODO this hashes twice (not that it really matters)
-
-whenHash
-  :: (Hashable a, MonadFinance m, MonadSqlQuery m)
-  => ConfigType
-  -> a
-  -> b
-  -> (CommitRId -> m b)
-  -> m b
-whenHash t o def f = do
-  let h = hash o
-  hs <- askDBState kmNewCommits
-  if h `elem` hs then f =<< insert (CommitR h t) else return def
-
-whenHash_
-  :: (Hashable a, MonadFinance m)
-  => ConfigType
-  -> a
-  -> m b
-  -> m (Maybe (CommitR, b))
-whenHash_ t o f = do
-  let h = hash o
-  let c = CommitR h t
-  hs <- askDBState kmNewCommits
-  if h `elem` hs then Just . (c,) <$> f else return Nothing

lib/Internal/Database/Ops.hs

@@ -8,6 +8,10 @@ module Internal.Database.Ops
   , flattenAcntRoot
   , paths2IDs
   , mkPool
+  , whenHash
+  , whenHash_
+  , insertSplit
+  , resolveSplit
   )
 where
 
@@ -24,6 +28,7 @@ import Database.Persist.Sqlite hiding
   , deleteWhere
   , insert
   , insertKey
+  , insert_
   , runMigration
   , (==.)
   , (||.)
@@ -319,8 +324,8 @@ getDBState c = do
       , kmCurrenciesOld = cs
       }
   where
-    bi = liftExcept $ resolveBounds $ budgetInterval $ global c
+    bi = liftExcept $ resolveDaySpan $ budgetInterval $ global c
-    si = liftExcept $ resolveBounds $ statementInterval $ global c
+    si = liftExcept $ resolveDaySpan $ statementInterval $ global c
     (acnts, paths, am) = indexAcntRoot $ accounts c
     cs = currency2Record <$> currencies c
     ts = toRecord <$> tags c
@@ -371,3 +376,50 @@ deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q)
 
 selectE :: (MonadSqlQuery m, SqlSelect a r) => E.SqlQuery a -> m [r]
 selectE q = unsafeLiftSql "esqueleto-select" (E.select q)
+
+whenHash
+  :: (Hashable a, MonadFinance m, MonadSqlQuery m)
+  => ConfigType
+  -> a
+  -> b
+  -> (CommitRId -> m b)
+  -> m b
+whenHash t o def f = do
+  let h = hash o
+  hs <- askDBState kmNewCommits
+  if h `elem` hs then f =<< insert (CommitR h t) else return def
+
+whenHash_
+  :: (Hashable a, MonadFinance m)
+  => ConfigType
+  -> a
+  -> m b
+  -> m (Maybe (CommitR, b))
+whenHash_ t o f = do
+  let h = hash o
+  let c = CommitR h t
+  hs <- askDBState kmNewCommits
+  if h `elem` hs then Just . (c,) <$> f else return Nothing
+
+insertSplit :: MonadSqlQuery m => TransactionRId -> KeySplit -> m SplitRId
+insertSplit t Entry {eAcnt, eCurrency, eValue, eComment, eTags} = do
+  k <- insert $ SplitR t eCurrency eAcnt eComment eValue
+  mapM_ (insert_ . TagRelationR k) eTags
+  return k
+
+resolveSplit :: (MonadInsertError m, MonadFinance m) => BalSplit -> m KeySplit
+resolveSplit s@Entry {eAcnt, eCurrency, eValue, eTags} = do
+  let aRes = lookupAccountKey eAcnt
+  let cRes = lookupCurrencyKey eCurrency
+  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
+        { eAcnt = aid
+        , eCurrency = cid
+        , eValue = eValue * fromIntegral (sign2Int sign)
+        , eTags = tags
+        }

lib/Internal/History.hs

@@ -0,0 +1,133 @@
+module Internal.History
+  ( splitHistory
+  , insertHistTransfer
+  , readHistStmt
+  , insertHistStmt
+  )
+where
+
+import Control.Monad.Except
+import Database.Persist.Monad
+import Internal.Database.Ops
+import Internal.Statement
+import Internal.Types.Main
+import Internal.Utils
+import RIO hiding (to)
+import qualified RIO.Text as T
+import RIO.Time
+
+--------------------------------------------------------------------------------
+-- budget
+
+-- each budget (designated at the top level by a 'name') is processed in the
+-- following steps
+-- 1. expand all transactions given the desired date range and date patterns for
+--    each directive in the budget
+-- 2. sort all transactions by date
+-- 3. propagate all balances forward, and while doing so assign values to each
+--    transaction (some of which depend on the 'current' balance of the
+--    target account)
+-- 4. assign shadow transactions (TODO)
+-- 5. insert all transactions
+
+--------------------------------------------------------------------------------
+-- statements
+
+splitHistory :: [History] -> ([HistTransfer], [Statement])
+splitHistory = partitionEithers . fmap go
+  where
+    go (HistTransfer x) = Left x
+    go (HistStatement x) = Right x
+
+-- insertStatement
+--   :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m)
+--   => History
+--   -> m ()
+-- insertStatement (HistTransfer m) = liftIOExceptT $ insertManual m
+-- insertStatement (HistStatement i) = insertImport i
+
+insertHistTransfer
+  :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
+  => HistTransfer
+  -> m ()
+insertHistTransfer
+  m@Transfer
+    { transFrom = from
+    , transTo = to
+    , transCurrency = u
+    , transAmounts = amts
+    } = do
+    whenHash CTManual m () $ \c -> do
+      bounds <- askDBState kmStatementInterval
+      let precRes = lookupCurrencyPrec u
+      let go Amount {amtWhen, amtValue, amtDesc} = do
+            let dayRes = liftExcept $ expandDatePat bounds amtWhen
+            (days, precision) <- combineError dayRes precRes (,)
+            let tx day = txPair day from to u (roundPrecision precision amtValue) amtDesc
+            keys <- combineErrors $ fmap tx days
+            mapM_ (insertTx c) keys
+      void $ combineErrors $ fmap go amts
+
+readHistStmt :: (MonadUnliftIO m, MonadFinance m) => Statement -> m (Maybe (CommitR, [KeyTx]))
+readHistStmt i = whenHash_ CTImport i $ do
+  bs <- readImport i
+  bounds <- askDBState kmStatementInterval
+  liftIOExceptT $ mapErrors resolveTx $ filter (inDaySpan bounds . txDate) bs
+
+insertHistStmt :: (MonadSqlQuery m) => CommitR -> [KeyTx] -> m ()
+insertHistStmt c ks = do
+  ck <- insert c
+  mapM_ (insertTx ck) ks
+
+-- insertImport
+--   :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m)
+--   => Statement
+--   -> m ()
+-- insertImport i = whenHash CTImport i () $ \c -> do
+--   -- TODO this isn't efficient, the whole file will be read and maybe no
+--   -- transactions will be desired
+--   bs <- readImport i
+--   bounds <- expandBounds <$> askDBState kmStatementInterval
+--   keys <- liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs
+--   mapM_ (insertTx c) keys
+
+--------------------------------------------------------------------------------
+-- low-level transaction stuff
+
+-- TODO tags here?
+txPair
+  :: (MonadInsertError m, MonadFinance m)
+  => Day
+  -> AcntID
+  -> AcntID
+  -> CurID
+  -> Rational
+  -> T.Text
+  -> m KeyTx
+txPair day from to cur val desc = resolveTx tx
+  where
+    split a v =
+      Entry
+        { eAcnt = a
+        , eValue = v
+        , eComment = ""
+        , eCurrency = cur
+        , eTags = []
+        }
+    tx =
+      Tx
+        { txDescr = desc
+        , txDate = day
+        , txSplits = [split from (-val), split to val]
+        }
+
+resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx
+resolveTx t@Tx {txSplits = ss} =
+  fmap (\kss -> t {txSplits = kss}) $
+    combineErrors $
+      fmap resolveSplit ss
+
+insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m ()
+insertTx c Tx {txDate = d, txDescr = e, txSplits = ss} = do
+  k <- insert $ TransactionR c d e
+  mapM_ (insertSplit k) ss

lib/Internal/Types/Main.hs

@@ -44,8 +44,8 @@ data DBState = DBState
   { kmCurrency :: !CurrencyMap
   , kmAccount :: !AccountMap
   , kmTag :: !TagMap
-  , kmBudgetInterval :: !Bounds
+  , kmBudgetInterval :: !DaySpan
-  , kmStatementInterval :: !Bounds
+  , kmStatementInterval :: !DaySpan
   , kmNewCommits :: ![Int]
   , kmOldCommits :: ![Int]
   , kmConfigDir :: !FilePath
@@ -63,35 +63,11 @@ type KeyTx = Tx KeySplit
 
 type TreeR = Tree ([T.Text], AccountRId)
 
-type Balances = M.Map AccountRId Rational
-
-type BalanceM = ReaderT (MVar Balances)
-
 type MonadFinance = MonadReader DBState
 
 askDBState :: MonadFinance m => (DBState -> a) -> m a
 askDBState = asks
 
-class MonadUnliftIO m => MonadBalance m where
-  askBalances :: m (MVar Balances)
-
-  withBalances :: (Balances -> m a) -> m a
-  withBalances f = do
-    bs <- askBalances
-    withMVar bs f
-
-  modifyBalances :: (Balances -> m (Balances, a)) -> m a
-  modifyBalances f = do
-    bs <- askBalances
-    modifyMVar bs f
-
-  lookupBalance :: AccountRId -> m Rational
-  lookupBalance i = withBalances $ return . fromMaybe 0 . M.lookup i
-
-  addBalance :: AccountRId -> Rational -> m ()
-  addBalance i v =
-    modifyBalances $ return . (,()) . M.alter (Just . maybe v (v +)) i
-
 -------------------------------------------------------------------------------
 -- misc
 
@@ -125,8 +101,7 @@ data TxRecord = TxRecord
   }
   deriving (Show, Eq, Ord)
 
--- TODO pick a better name for this (something like DayInterval or something)
+type DaySpan = (Day, Natural)
-type Bounds = (Day, Natural)
 
 data Keyed a = Keyed
   { kKey :: !Int64
@@ -196,7 +171,7 @@ data InsertError
   | BalanceError !BalanceType !CurID ![RawSplit]
   | IncomeError !Day !T.Text !Rational
   | PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
-  | BoundsError !Gregorian !(Maybe Gregorian)
+  | DaySpanError !Gregorian !(Maybe Gregorian)
   | StatementError ![TxRecord] ![MatchRe]
   | PeriodError !Day !Day
   deriving (Show)

lib/Internal/Utils.hs

@@ -1,14 +1,15 @@
 module Internal.Utils
   ( compareDate
+  , expandDatePat
+  , askDays
   , fromWeekday
-  , inBounds
+  , inDaySpan
-  , expandBounds
   , fmtRational
   , matches
   , fromGregorian'
-  , resolveBounds
+  , resolveDaySpan
-  , resolveBounds_
+  , resolveDaySpan_
-  , intersectBounds
+  , intersectDaySpan
   , liftInner
   , liftExceptT
   , liftExcept
@@ -48,6 +49,12 @@ module Internal.Utils
   , valMatches
   , roundPrecision
   , roundPrecisionCur
+  , lookupAccountKey
+  , lookupAccountSign
+  , lookupAccountType
+  , lookupCurrencyKey
+  , lookupCurrencyPrec
+  , lookupTag
   )
 where
 
@@ -66,6 +73,96 @@ import RIO.Time
 import Text.Regex.TDFA
 import Text.Regex.TDFA.Text
 
+--------------------------------------------------------------------------------
+-- intervals
+
+expandDatePat :: DaySpan -> DatePat -> InsertExcept [Day]
+expandDatePat b (Cron cp) = expandCronPat b cp
+expandDatePat i (Mod mp) = return $ expandModPat mp i
+
+expandModPat :: ModPat -> DaySpan -> [Day]
+expandModPat ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r} bs =
+  takeWhile (<= upper) $
+    (`addFun` start) . (* b')
+      <$> maybe id (take . fromIntegral) r [0 ..]
+  where
+    (lower, upper) = fromDaySpan bs
+    start = maybe lower fromGregorian' s
+    b' = fromIntegral b
+    addFun = case u of
+      Day -> addDays
+      Week -> addDays . (* 7)
+      Month -> addGregorianMonthsClip
+      Year -> addGregorianYearsClip
+
+expandCronPat :: DaySpan -> CronPat -> InsertExcept [Day]
+expandCronPat b CronPat {cpYear, cpMonth, cpDay, cpWeekly} =
+  combineError3 yRes mRes dRes $ \ys ms ds ->
+    filter validWeekday $
+      mapMaybe (uncurry3 toDay) $
+        takeWhile (\((y, _), m, d) -> (y, m, d) <= (yb1, mb1, db1)) $
+          dropWhile (\((y, _), m, d) -> (y, m, d) < (yb0, mb0, db0)) $
+            [(y, m, d) | y <- (\y -> (y, isLeapYear y)) <$> ys, m <- ms, d <- ds]
+  where
+    yRes = case cpYear of
+      Nothing -> return [yb0 .. yb1]
+      Just pat -> do
+        ys <- expandMDYPat (fromIntegral yb0) (fromIntegral yb1) pat
+        return $ dropWhile (< yb0) $ fromIntegral <$> ys
+    mRes = expandMD 12 cpMonth
+    dRes = expandMD 31 cpDay
+    (s, e) = fromDaySpan b
+    (yb0, mb0, db0) = toGregorian s
+    (yb1, mb1, db1) = toGregorian $ addDays (-1) e
+    expandMD lim =
+      fmap (fromIntegral <$>)
+        . maybe (return [1 .. lim]) (expandMDYPat 1 lim)
+    expandW (OnDay x) = [fromEnum x]
+    expandW (OnDays xs) = fromEnum <$> xs
+    ws = maybe [] expandW cpWeekly
+    validWeekday = if null ws then const True else \day -> dayToWeekday day `elem` ws
+    toDay (y, leap) m d
+      | m == 2 && (not leap && d > 28 || leap && d > 29) = Nothing
+      | m `elem` [4, 6, 9, 11] && d > 30 = Nothing
+      | otherwise = Just $ fromGregorian y m d
+
+expandMDYPat :: Natural -> Natural -> MDYPat -> InsertExcept [Natural]
+expandMDYPat lower upper (Single x) = return [x | lower <= x && x <= upper]
+expandMDYPat lower upper (Multi xs) = return $ dropWhile (<= lower) $ takeWhile (<= upper) xs
+expandMDYPat lower upper (After x) = return [max lower x .. upper]
+expandMDYPat lower upper (Before x) = return [lower .. min upper x]
+expandMDYPat lower upper (Between x y) = return [max lower x .. min upper y]
+expandMDYPat lower upper (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = r})
+  | b < 1 = throwError $ InsertException [PatternError s b r ZeroLength]
+  | otherwise = do
+      k <- limit r
+      return $ dropWhile (<= lower) $ takeWhile (<= k) [s + i * b | i <- [0 ..]]
+  where
+    limit Nothing = return upper
+    limit (Just n)
+      -- this guard not only produces the error for the user but also protects
+      -- from an underflow below it
+      | n < 1 = throwError $ InsertException [PatternError s b r ZeroRepeats]
+      | otherwise = return $ min (s + b * (n - 1)) upper
+
+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
+  globalSpan <- askDBState kmBudgetInterval
+  case i of
+    Just i' -> do
+      localSpan <- liftExcept $ resolveDaySpan i'
+      maybe (return []) expand $ intersectDaySpan globalSpan localSpan
+    Nothing -> expand globalSpan
+  where
+    expand = liftExcept . (`expandDatePat` dp)
+
 --------------------------------------------------------------------------------
 -- dates
 
@@ -152,39 +249,42 @@ compareDate (In md offset) x = do
 fromGregorian' :: Gregorian -> Day
 fromGregorian' = uncurry3 fromGregorian . gregTup
 
-inBounds :: Bounds -> Day -> Bool
+inDaySpan :: DaySpan -> Day -> Bool
-inBounds bs = withinDays (expandBounds bs)
+inDaySpan bs = withinDays (fromDaySpan bs)
 
 withinDays :: (Day, Day) -> Day -> Bool
 withinDays (d0, d1) x = d0 <= x && x < d1
 
-resolveBounds :: Interval -> InsertExcept Bounds
+resolveDaySpan :: Interval -> InsertExcept DaySpan
-resolveBounds i@Interval {intStart = s} =
+resolveDaySpan i@Interval {intStart = s} =
-  resolveBounds_ (s {gYear = gYear s + 50}) i
+  resolveDaySpan_ (s {gYear = gYear s + 50}) i
 
--- TODO not DRY
+intersectDaySpan :: DaySpan -> DaySpan -> Maybe DaySpan
-intersectBounds :: Bounds -> Bounds -> Maybe Bounds
+intersectDaySpan a b =
-intersectBounds a b =
+  if b' > a' then Nothing else Just $ toDaySpan (a', b')
-  if b' > a' then Nothing else Just (a', fromIntegral $ diffDays b' a' - 1)
   where
-    (a0, a1) = expandBounds a
+    (a0, a1) = fromDaySpan a
-    (b0, b1) = expandBounds b
+    (b0, b1) = fromDaySpan b
     a' = max a0 a1
     b' = min b0 b1
 
-resolveBounds_ :: Gregorian -> Interval -> InsertExcept Bounds
+resolveDaySpan_ :: Gregorian -> Interval -> InsertExcept DaySpan
-resolveBounds_ def Interval {intStart = s, intEnd = e} =
+resolveDaySpan_ def Interval {intStart = s, intEnd = e} =
   case fromGregorian' <$> e of
-    Nothing -> return $ toBounds $ fromGregorian' def
+    Nothing -> return $ toDaySpan_ $ fromGregorian' def
     Just e_
-      | s_ < e_ -> return $ toBounds e_
+      | s_ < e_ -> return $ toDaySpan_ e_
-      | otherwise -> throwError $ InsertException [BoundsError s e]
+      | otherwise -> throwError $ InsertException [DaySpanError s e]
   where
     s_ = fromGregorian' s
-    toBounds end = (s_, fromIntegral $ diffDays end s_ - 1)
+    toDaySpan_ end = toDaySpan (s_, end)
 
-expandBounds :: Bounds -> (Day, Day)
+fromDaySpan :: DaySpan -> (Day, Day)
-expandBounds (d, n) = (d, addDays (fromIntegral n + 1) d)
+fromDaySpan (d, n) = (d, addDays (fromIntegral n + 1) d)
+
+-- ASSUME a < b
+toDaySpan :: (Day, Day) -> DaySpan
+toDaySpan (a, b) = (a, fromIntegral $ diffDays b a - 1)
 
 --------------------------------------------------------------------------------
 -- matching
@@ -457,7 +557,7 @@ acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)
 showError :: InsertError -> [T.Text]
 showError other = case other of
   (StatementError ts ms) -> (showTx <$> ts) ++ (showMatch <$> ms)
-  (BoundsError a b) ->
+  (DaySpanError a b) ->
     [T.unwords ["Could not create bounds from", showGregorian_ a, "and", showGreg b]]
     where
       showGreg (Just g) = showGregorian_ g
@@ -794,3 +894,35 @@ matchGroupsMaybe q re = case regexec re q of
   Right (Just (_, _, _, xs)) -> xs
   -- this should never fail as regexec always returns Right
   Left _ -> []
+
+lookupAccount :: (MonadInsertError m, MonadFinance m) => AcntID -> m (AccountRId, AcntSign, AcntType)
+lookupAccount = lookupFinance AcntField kmAccount
+
+lookupAccountKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m AccountRId
+lookupAccountKey = fmap fstOf3 . lookupAccount
+
+lookupAccountSign :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntSign
+lookupAccountSign = fmap sndOf3 . lookupAccount
+
+lookupAccountType :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntType
+lookupAccountType = fmap thdOf3 . lookupAccount
+
+lookupCurrency :: (MonadInsertError m, MonadFinance m) => T.Text -> m (CurrencyRId, Natural)
+lookupCurrency = lookupFinance CurField kmCurrency
+
+lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m CurrencyRId
+lookupCurrencyKey = fmap fst . lookupCurrency
+
+lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => AcntID -> m Natural
+lookupCurrencyPrec = fmap snd . lookupCurrency
+
+lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId
+lookupTag = lookupFinance TagField kmTag
+
+lookupFinance
+  :: (MonadInsertError m, MonadFinance m)
+  => SplitIDType
+  -> (DBState -> M.Map T.Text a)
+  -> T.Text
+  -> m a
+lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f