ENH update types and use deferred allocation math

lib/Internal/Insert.hs

@@ -119,21 +119,20 @@ withDates dp f = do
 
 insertBudget :: MonadFinance m => Budget -> SqlPersistT m [InsertError]
 insertBudget
-  b@( Budget
+  b@Budget
-        { budgetLabel
+    { budgetLabel
-        , incomes
+    , incomes
-        , transfers
+    , transfers
-        , shadowTransfers
+    , shadowTransfers
-        , pretax
+    , pretax
-        , tax
+    , tax
-        , posttax
+    , posttax
-        }
+    } =
-      ) =
     whenHash CTBudget b [] $ \key -> do
       unlessLefts intAllos $ \intAllos_ -> do
         res1 <- mapM (insertIncome key budgetLabel intAllos_) incomes
         res2 <- expandTransfers key budgetLabel transfers
-        unlessLefts (concatEithers2 (fmap concat $ concatEithersL res1) res2 (++)) $
+        unlessLefts (concatEithers2 (concat <$> concatEithersL res1) res2 (++)) $
           \txs -> do
             unlessLefts (addShadowTransfers shadowTransfers txs) $ \shadow -> do
               let bals = balanceTransfers $ txs ++ shadow
@@ -146,117 +145,120 @@ insertBudget
          in concatEithers3 pre_ tax_ post_ (,,)
       sortAllos = concatEithersL . fmap sortAllo
 
-type BoundAllocation = Allocation_ (TimeAmount (Day, Day))
+type BoundAllocation = Allocation (Day, Day)
 
-type IntAllocations = ([BoundAllocation], [BoundAllocation], [BoundAllocation])
+type IntAllocations =
+  ( [BoundAllocation PretaxValue]
+  , [BoundAllocation TaxValue]
+  , [BoundAllocation PosttaxValue]
+  )
 
--- TODO this should actually error if there is no ultimate end date
+-- TODO this should actually error if there is no ultimate end date?
-sortAllo :: IntervalAllocation -> EitherErrs BoundAllocation
+sortAllo :: MultiAllocation v -> EitherErrs (BoundAllocation v)
-sortAllo a@Allocation_ {alloAmts = as} = do
+sortAllo a@Allocation {alloAmts = as} = do
-  bs <- fmap reverse <$> foldBounds (Right []) $ L.sortOn taWhen as
+  bs <- foldBounds (Right []) $ L.sortOn amtWhen as
-  return $ a {alloAmts = L.sort bs}
+  return $ a {alloAmts = reverse bs}
   where
     foldBounds acc [] = acc
     foldBounds acc (x : xs) =
-      let res = fmap (fmap expandBounds) $ case xs of
+      let res = case xs of
-            [] -> mapM resolveBounds x
+            [] -> resolveBounds $ amtWhen x
-            (y : _) ->
+            (y : _) -> resolveBounds_ (intStart $ amtWhen y) $ amtWhen x
-              let end = intStart $ taWhen y
+          concatRes bs acc' = x {amtWhen = expandBounds bs} : acc'
-               in mapM (resolveBounds_ end) x
+       in foldBounds (concatEithers2 (plural res) acc concatRes) xs
-       in foldBounds (concatEithers2 (plural res) acc (:)) xs
 
 -- TODO this is going to be O(n*m), which might be a problem?
-addShadowTransfers :: [ShadowTransfer] -> [BudgetTxType] -> EitherErrs [BudgetTxType]
+addShadowTransfers
+  :: [ShadowTransfer]
+  -> [UnbalancedTransfer]
+  -> EitherErrs [UnbalancedTransfer]
 addShadowTransfers ms txs =
   fmap catMaybes $
     concatEitherL $
       fmap (uncurry fromShadow) $
         [(t, m) | t <- txs, m <- ms]
 
-fromShadow :: BudgetTxType -> ShadowTransfer -> EitherErr (Maybe BudgetTxType)
+fromShadow
-fromShadow tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio} = do
+  :: UnbalancedTransfer
+  -> ShadowTransfer
+  -> EitherErr (Maybe UnbalancedTransfer)
+fromShadow tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do
   res <- shadowMatches (stMatch t) tx
   return $
     if not res
       then Nothing
       else
         Just $
-          BudgetTxType
+          -- TODO does this actually share the same metadata as the "parent" tx?
-            { bttTx =
+          FlatTransfer
-                -- TODO does this actually share the same metadata as the "parent" tx?
+            { cbtMeta = cbtMeta tx
-                BudgetTx
+            , cbtWhen = cbtWhen tx
-                  { btMeta = btMeta $ bttTx tx
+            , cbtCur = stCurrency
-                  , btWhen = btWhen $ bttTx tx
+            , cbtFrom = stFrom
-                  , btFrom = stFrom
+            , cbtTo = stTo
-                  , btTo = stTo
+            , cbtValue = UnbalancedValue stType $ dec2Rat stRatio * cvValue (cbtValue tx)
-                  , btValue = dec2Rat stRatio * (btValue $ bttTx tx)
+            , cbtDesc = stDesc
-                  , btDesc = stDesc
-                  }
-            , bttType = FixedAmt
             }
 
-shadowMatches :: ShadowMatch -> BudgetTxType -> EitherErr Bool
+shadowMatches :: TransferMatcher -> UnbalancedTransfer -> EitherErr Bool
-shadowMatches ShadowMatch {smFrom, smTo, smDate, smVal} tx = do
+shadowMatches TransferMatcher {smFrom, smTo, smDate, smVal} tx = do
-  -- TODO what does the amount do for each of the different types?
+  valRes <- valMatches smVal $ cvValue $ cbtValue tx
-  valRes <- valMatches smVal (btValue tx_)
   return $
-    memberMaybe (taAcnt $ btFrom tx_) smFrom
+    memberMaybe (taAcnt $ cbtFrom tx) smFrom
-      && memberMaybe (taAcnt $ btTo tx_) smTo
+      && memberMaybe (taAcnt $ cbtTo tx) smTo
-      && maybe True (`dateMatches` (btWhen tx_)) smDate
+      && maybe True (`dateMatches` cbtWhen tx) smDate
       && valRes
   where
-    tx_ = bttTx tx
     memberMaybe x AcntSet {asList, asInclude} =
       (if asInclude then id else not) $ x `elem` asList
 
-balanceTransfers :: [BudgetTxType] -> [BudgetTx]
+balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer]
 balanceTransfers ts =
-  snd $ L.mapAccumR go initBals $ reverse $ L.sortOn (btWhen . bttTx) ts
+  snd $ L.mapAccumR go M.empty $ reverse $ L.sortOn cbtWhen ts
   where
-    initBals =
+    go bals f@FlatTransfer {cbtFrom, cbtTo, cbtValue = UnbalancedValue {cvValue, cvType}} =
-      M.fromList $
+      let (bals', v) = mapAdd cbtTo x $ mapAdd_ cbtFrom (-x) bals
-        fmap (,0) $
+          x = amtToMove v cvType cvValue
-          L.nub $
+       in (bals', f {cbtValue = x})
-            fmap (btTo . bttTx) ts
-              ++ fmap (btFrom . bttTx) ts
-    updateBal x = M.update (Just . (+ x))
-    lookupBal = M.findWithDefault (error "this should not happen")
-    go bals btt =
-      let tx = bttTx btt
-          from = btFrom tx
-          to = btTo tx
-          bal = lookupBal to bals
-          x = amtToMove bal (bttType btt) (btValue tx)
-       in (updateBal x to $ updateBal (-x) from bals, tx {btValue = 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
-    amtToMove _ FixedAmt x = x
+    amtToMove _ BTFixed x = x
-    amtToMove bal Percent x = -(x / 100 * bal)
+    amtToMove bal BTPercent x = -(x / 100 * bal)
-    amtToMove bal Target x = x - bal
+    amtToMove bal BTTarget x = x - bal
+
+mapAdd_ :: (Ord k, Num v) => k -> v -> M.Map k v -> M.Map k v
+mapAdd_ k v m = fst $ mapAdd k v m
+
+mapAdd :: (Ord k, Num v) => k -> v -> M.Map k v -> (M.Map k v, v)
+mapAdd k v m = (new, M.findWithDefault (error "this should not happen") k new)
+  where
+    new = M.alter (maybe (Just v) (Just . (+ v))) k m
 
 data BudgetMeta = BudgetMeta
   { bmCommit :: !CommitRId
-  , bmCur :: !BudgetCurrency
   , bmName :: !T.Text
   }
   deriving (Show)
 
-data BudgetTx = BudgetTx
+data FlatTransfer v = FlatTransfer
-  { btMeta :: !BudgetMeta
+  { cbtFrom :: !TaggedAcnt
-  , btWhen :: !Day
+  , cbtTo :: !TaggedAcnt
-  , btFrom :: !TaggedAcnt
+  , cbtValue :: !v
-  , btTo :: !TaggedAcnt
+  , cbtWhen :: !Day
-  , btValue :: !Rational
+  , cbtDesc :: !T.Text
-  , btDesc :: !T.Text
+  , cbtMeta :: !BudgetMeta
+  , cbtCur :: !BudgetCurrency
   }
-  deriving (Show)
 
-data BudgetTxType = BudgetTxType
+data UnbalancedValue = UnbalancedValue
-  { bttType :: !AmountType
+  { cvType :: !BudgetTransferType
-  , bttTx :: !BudgetTx
+  , cvValue :: !Rational
   }
-  deriving (Show)
+
+type UnbalancedTransfer = FlatTransfer UnbalancedValue
+
+type BalancedTransfer = FlatTransfer Rational
 
 insertIncome
   :: MonadFinance m
@@ -264,179 +266,206 @@ insertIncome
   -> T.Text
   -> IntAllocations
   -> Income
-  -> SqlPersistT m (EitherErrs [BudgetTxType])
+  -> SqlPersistT m (EitherErrs [UnbalancedTransfer])
 insertIncome
   key
   name
   (intPre, intTax, intPost)
-  i@Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal} = do
+  Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal, incGross} = do
-    let meta = BudgetMeta key (NoX incCurrency) name
+    -- TODO check that the other accounts are not income somewhere here
-    let balRes = balanceIncome i
     fromRes <- lift $ checkAcntType IncomeT $ taAcnt incFrom
-    case concatEither2 balRes fromRes (,) of
+    case fromRes of
-      Left es -> return $ Left es
+      Left e -> return $ Left [e]
-      -- TODO this hole seems sloppy...
+      -- TODO this will scan the interval allocations fully each time
-      Right (balance, _) ->
+      -- iteration which is a total waste, but the fix requires turning this
-        fmap (fmap (concat . concat)) $
+      -- loop into a fold which I don't feel like doing now :(
-          -- TODO this will scan the interval allocations fully each time
+      Right _ -> fmap concat <$> withDates incWhen (return . allocate)
-          -- iteration which is a total waste, but the fix requires turning this
+    where
-          -- loop into a fold which I don't feel like doing now :(
+      meta = BudgetMeta key name
-          withDates incWhen $ \day -> do
+      gross = dec2Rat incGross
-            let fromAllos = fmap concat . mapM (lift . fromAllo day meta incFrom)
+      flatPre = concatMap flattenAllo incPretax
-            pre <- fromAllos $ incPretax ++ mapMaybe (selectAllos day) intPre
+      flatTax = concatMap flattenAllo incTaxes
-            -- TODO ensure these are all expense accounts
+      flatPost = concatMap flattenAllo incPosttax
-            tax <- fromAllos $ incTaxes ++ mapMaybe (selectAllos day) intTax
+      sumAllos = sum . fmap faValue
-            post <- fromAllos $ incPosttax ++ mapMaybe (selectAllos day) intPost
+      -- TODO ensure these are all the "correct" accounts
-            let bal =
+      allocate day =
-                  BudgetTxType
+        let (preDeductions, pre) =
-                    { bttTx =
+              allocatePre gross $
-                        BudgetTx
+                flatPre ++ concatMap (selectAllos day) intPre
-                          { btMeta = meta
+            tax =
-                          , btWhen = day
+              allocateTax gross preDeductions $
-                          , btFrom = incFrom
+                flatTax ++ concatMap (selectAllos day) intTax
-                          , btTo = incToBal
+            aftertaxGross = sumAllos $ tax ++ pre
-                          , btValue = balance
+            post =
-                          , btDesc = "balance after deductions"
+              allocatePost aftertaxGross $
-                          }
+                flatPost ++ concatMap (selectAllos day) intPost
-                    , bttType = FixedAmt
+            balance = aftertaxGross - sumAllos post
-                    }
+            bal =
-            return $ concatEithersL [Right [bal], Right tax, Right pre, Right post]
+              FlatTransfer
+                { cbtMeta = meta
+                , cbtWhen = day
+                , cbtFrom = incFrom
+                , cbtCur = NoX incCurrency
+                , cbtTo = incToBal
+                , cbtValue = UnbalancedValue BTFixed balance
+                , cbtDesc = "balance after deductions"
+                }
+         in if balance < 0
+              then Left [IncomeError day name balance]
+              else Right $ bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post)
 
--- ASSUME allocations are sorted
+allocatePre
-selectAllos :: Day -> BoundAllocation -> Maybe Allocation
+  :: Rational
-selectAllos day a@Allocation_ {alloAmts = as} = case select [] as of
+  -> [FlatAllocation PretaxValue]
-  [] -> Nothing
+  -> (M.Map T.Text Rational, [FlatAllocation Rational])
-  xs -> Just $ a {alloAmts = xs}
+allocatePre gross = L.mapAccumR go M.empty
   where
-    select acc [] = acc
+    go m f@FlatAllocation {faValue} =
-    select acc (x : xs)
+      let c = preCategory faValue
-      | day < fst (taWhen x) = select acc xs
+          p = dec2Rat $ preValue faValue
-      | inBounds (taWhen x) day = select (taAmt x : acc) xs
+          v = if prePercent faValue then p * gross else p
-      | otherwise = acc
+       in (mapAdd_ c v m, f {faValue = v})
 
-fromAllo
+allo2Trans
-  :: MonadFinance m
+  :: BudgetMeta
-  => Day
+  -> Day
-  -> BudgetMeta
   -> TaggedAcnt
-  -> Allocation
+  -> FlatAllocation Rational
-  -> m [BudgetTxType]
+  -> UnbalancedTransfer
-fromAllo day meta from Allocation_ {alloTo, alloAmts} = do
+allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} =
-  -- TODO this is going to be repeated a zillion times (might matter)
+  FlatTransfer
-  -- res <- expandTarget alloPath
+    { cbtMeta = meta
-  return $ fmap toBT alloAmts
+    , cbtWhen = day
+    , cbtFrom = from
+    , cbtCur = faCur
+    , cbtTo = faTo
+    , cbtValue = UnbalancedValue BTFixed faValue
+    , cbtDesc = faDesc
+    }
+
+allocateTax
+  :: Rational
+  -> M.Map T.Text Rational
+  -> [FlatAllocation TaxValue]
+  -> [FlatAllocation Rational]
+allocateTax gross deds = fmap (fmap go)
   where
-    toBT (Amount {amtDesc = desc, amtValue = v}) =
+    go TaxValue {tvCategories, tvMethod} =
-      BudgetTxType
+      let agi = gross - sum (mapMaybe (`M.lookup` deds) tvCategories)
-        { bttTx =
+       in case tvMethod of
-            BudgetTx
+            TMPercent p -> dec2Rat p * agi
-              { btFrom = from
+            TMBracket TaxProgression {tbsDeductible, tbsBrackets} ->
-              , btWhen = day
+              foldBracket (agi - dec2Rat tbsDeductible) tbsBrackets
-              , btTo = alloTo
+
-              , btValue = dec2Rat v
+allocatePost
-              , btDesc = desc
+  :: Rational
-              , btMeta = meta
+  -> [FlatAllocation PosttaxValue]
-              }
+  -> [FlatAllocation Rational]
-        , bttType = FixedAmt
+allocatePost aftertax = fmap (fmap go)
+  where
+    go PosttaxValue {postValue, postPercent} =
+      let v = dec2Rat postValue in if postPercent then aftertax * v else v
+
+foldBracket :: Rational -> [TaxBracket] -> Rational
+foldBracket agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
+  where
+    go TaxBracket {tbLowerLimit, tbPercent} (acc, remain) =
+      let l = dec2Rat tbLowerLimit
+          p = dec2Rat tbPercent
+       in if remain < l then (acc + p * (remain - l), l) else (acc, remain)
+
+data FlatAllocation v = FlatAllocation
+  { faValue :: !v
+  , faDesc :: !T.Text
+  , faTo :: !TaggedAcnt
+  , faCur :: !BudgetCurrency
+  }
+  deriving (Functor)
+
+flattenAllo :: SingleAllocation v -> [FlatAllocation v]
+flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts
+  where
+    go Amount {amtValue, amtDesc} =
+      FlatAllocation
+        { faCur = NoX alloCur
+        , faTo = alloTo
+        , faValue = amtValue
+        , faDesc = amtDesc
         }
 
--- -- TODO maybe allow tags here?
+-- ASSUME allocations are sorted
--- fromTax
+selectAllos :: Day -> BoundAllocation v -> [FlatAllocation v]
---   :: MonadFinance m
+selectAllos day Allocation {alloAmts, alloCur, alloTo} =
---   => Day
+  fmap go $
---   -> BudgetMeta
+    takeWhile ((`inBounds` day) . amtWhen) $
---   -> AcntID
+      dropWhile ((day <) . fst . amtWhen) alloAmts
---   -> Tax
+  where
---   -> m (EitherErr BudgetTxType)
+    go Amount {amtValue, amtDesc} =
--- fromTax day meta from Tax {taxAcnt = to, taxValue = v} = do
+      FlatAllocation
---   res <- checkAcntType ExpenseT to
+        { faCur = NoX alloCur
---   return $ fmap go res
+        , faTo = alloTo
---   where
+        , faValue = amtValue
---     go to_ =
+        , faDesc = amtDesc
---       BudgetTxType
+        }
---         { bttTx =
---             BudgetTx
---               { btFrom = TaggedAcnt from []
---               , btWhen = day
---               , btTo = TaggedAcnt to_ []
---               , btValue = dec2Rat v
---               , btDesc = ""
---               , btMeta = meta
---               }
---         , bttType = FixedAmt
---         }
-
-balanceIncome :: Income -> EitherErr Rational
-balanceIncome
-  Income
-    { incGross = g
-    , incWhen = dp
-    , incPretax = pre
-    , incTaxes = tax
-    , incPosttax = post
-    }
-    | bal < 0 = Left $ IncomeError dp
-    | otherwise = Right bal
-    where
-      bal = dec2Rat g - sum (sumAllocation <$> pre ++ tax ++ post)
-
-sumAllocation :: Allocation -> Rational
-sumAllocation = sum . fmap (dec2Rat . amtValue) . alloAmts
-
--- sumTaxes :: [Tax] -> Rational
--- sumTaxes = sum . fmap (dec2Rat . taxValue)
 
 expandTransfers
   :: MonadFinance m
   => CommitRId
   -> T.Text
-  -> [Transfer]
+  -> [BudgetTransfer]
-  -> SqlPersistT m (EitherErrs [BudgetTxType])
+  -> SqlPersistT m (EitherErrs [UnbalancedTransfer])
 expandTransfers key name ts = do
   txs <- mapM (expandTransfer key name) ts
-  return $ L.sortOn (btWhen . bttTx) . concat <$> concatEithersL txs
+  return $ L.sortOn cbtWhen . concat <$> concatEithersL txs
 
-expandTransfer :: MonadFinance m => CommitRId -> T.Text -> Transfer -> SqlPersistT m (EitherErrs [BudgetTxType])
+expandTransfer
+  :: MonadFinance m
+  => CommitRId
+  -> T.Text
+  -> BudgetTransfer
+  -> SqlPersistT m (EitherErrs [UnbalancedTransfer])
 expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} =
   -- whenHash CTExpense t (Right []) $ \key ->
   fmap (fmap concat . concatEithersL) $
-    forM transAmounts $ \(TimeAmount {taWhen = pat, taAmt = (Amount {amtDesc = desc, amtValue = v}), taAmtType = atype}) -> do
+    forM transAmounts $
-      withDates pat $ \day ->
+      \Amount
-        let meta =
+        { amtWhen = pat
-              BudgetMeta
+        , amtValue = BudgetTransferValue {btVal = v, btType = y}
-                { bmCur = transCurrency
+        , amtDesc = desc
-                , bmCommit = key
+        } ->
-                , bmName = name
+          do
-                }
+            withDates pat $ \day ->
-            tx =
+              let meta =
-              BudgetTxType
+                    BudgetMeta
-                { bttTx =
+                      { bmCommit = key
-                    BudgetTx
+                      , bmName = name
-                      { btMeta = meta
-                      , btWhen = day
-                      , btFrom = transFrom
-                      , btTo = transTo
-                      , btValue = dec2Rat v
-                      , btDesc = desc
                       }
-                , bttType = atype
+                  tx =
-                }
+                    FlatTransfer
-         in return $ Right tx
+                      { cbtMeta = meta
+                      , cbtWhen = day
+                      , cbtCur = transCurrency
+                      , cbtFrom = transFrom
+                      , cbtTo = transTo
+                      , cbtValue = UnbalancedValue y $ dec2Rat v
+                      , cbtDesc = desc
+                      }
+               in return $ Right tx
 
-insertBudgetTx :: MonadFinance m => BudgetTx -> SqlPersistT m [InsertError]
+insertBudgetTx :: MonadFinance m => BalancedTransfer -> SqlPersistT m [InsertError]
-insertBudgetTx BudgetTx {btFrom, btTo, btMeta, btValue, btDesc, btWhen} = do
+insertBudgetTx FlatTransfer {cbtFrom, cbtTo, cbtMeta, cbtCur, cbtValue, cbtDesc, cbtWhen} = do
-  res <- lift $ splitPair btFrom btTo (bmCur btMeta) btValue
+  res <- lift $ splitPair cbtFrom cbtTo cbtCur cbtValue
   unlessLefts_ res $ \((sFrom, sTo), exchange) -> do
     insertPair sFrom sTo
-    forM_ exchange $ \(xFrom, xTo) -> insertPair xFrom xTo
+    forM_ exchange $ uncurry insertPair
   where
     insertPair from to = do
-      k <- insert $ TransactionR (bmCommit btMeta) btWhen btDesc
+      k <- insert $ TransactionR (bmCommit cbtMeta) cbtWhen cbtDesc
       insertBudgetLabel k from
       insertBudgetLabel k to
     insertBudgetLabel k split = do
       sk <- insertSplit k split
-      insert_ $ BudgetLabelR sk $ bmName btMeta
+      insert_ $ BudgetLabelR sk $ bmName cbtMeta
 
 type SplitPair = (KeySplit, KeySplit)
 
@@ -448,8 +477,8 @@ splitPair
   -> Rational
   -> m (EitherErrs (SplitPair, Maybe SplitPair))
 splitPair from to cur val = case cur of
-  NoX curid -> fmap (fmap (,Nothing)) $ pair curid from to val
+  NoX curid -> fmap (,Nothing) <$> pair curid from to val
-  X (Exchange {xFromCur, xToCur, xAcnt, xRate}) -> do
+  X Exchange {xFromCur, xToCur, xAcnt, xRate} -> do
     let middle = TaggedAcnt xAcnt []
     res1 <- pair xFromCur from middle val
     res2 <- pair xToCur middle to (val * dec2Rat xRate)
@@ -461,7 +490,7 @@ splitPair from to cur val = case cur of
       return $ concatEithers2 s1 s2 (,)
     split c TaggedAcnt {taAcnt, taTags} v =
       resolveSplit $
-        Split
+        Entry
           { sAcnt = taAcnt
           , sValue = v
           , sComment = ""
@@ -493,31 +522,31 @@ checkAcntTypes ts i = (go =<<) <$> lookupAccountType i
 insertStatements :: MonadFinance m => Config -> SqlPersistT m [InsertError]
 insertStatements conf = concat <$> mapM insertStatement (statements conf)
 
-insertStatement :: MonadFinance m => Statement -> SqlPersistT m [InsertError]
+insertStatement :: MonadFinance m => History -> SqlPersistT m [InsertError]
-insertStatement (StmtManual m) = insertManual m
+insertStatement (HistTransfer m) = insertManual m
-insertStatement (StmtImport i) = insertImport i
+insertStatement (HistStatement i) = insertImport i
 
-insertManual :: MonadFinance m => Manual -> SqlPersistT m [InsertError]
+insertManual :: MonadFinance m => HistTransfer -> SqlPersistT m [InsertError]
 insertManual
-  m@Manual
+  m@Transfer
-    { manualDate = dp
+    { transFrom = from
-    , manualFrom = from
+    , transTo = to
-    , manualTo = to
+    , transCurrency = u
-    , manualValue = v
+    , transAmounts = amts
-    , manualCurrency = u
-    , manualDesc = e
     } = do
     whenHash CTManual m [] $ \c -> do
       bounds <- lift $ askDBState kmStatementInterval
       -- let days = expandDatePat bounds dp
-      let dayRes = expandDatePat bounds dp
+      es <- forM amts $ \Amount {amtWhen, amtValue, amtDesc} -> do
-      unlessLefts dayRes $ \days -> do
+        let v = dec2Rat amtValue
-        txRes <- mapM (lift . tx) days
+        let dayRes = expandDatePat bounds amtWhen
-        unlessLefts_ (concatEithersL txRes) $ mapM_ (insertTx c)
+        unlessLefts dayRes $ \days -> do
-    where
+          let tx day = txPair day from to u v amtDesc
-      tx day = txPair day from to u (dec2Rat v) e
+          txRes <- mapM (lift . tx) days
+          unlessLefts_ (concatEithersL txRes) $ mapM_ (insertTx c)
+      return $ concat es
 
-insertImport :: MonadFinance m => Import -> SqlPersistT m [InsertError]
+insertImport :: MonadFinance m => Statement -> SqlPersistT m [InsertError]
 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
@@ -549,7 +578,7 @@ txPair
   -> m (EitherErrs KeyTx)
 txPair day from to cur val desc = resolveTx tx
   where
-    split a v = Split {sAcnt = a, sValue = v, sComment = "", sCurrency = cur, sTags = []}
+    split a v = Entry {sAcnt = a, sValue = v, sComment = "", sCurrency = cur, sTags = []}
     tx =
       Tx
         { txDescr = desc
@@ -563,7 +592,7 @@ resolveTx t@Tx {txSplits = ss} = do
   return $ fmap (\kss -> t {txSplits = kss}) res
 
 resolveSplit :: MonadFinance m => BalSplit -> m (EitherErrs KeySplit)
-resolveSplit s@Split {sAcnt, sCurrency, sValue, sTags} = do
+resolveSplit s@Entry {sAcnt, sCurrency, sValue, sTags} = do
   aid <- lookupAccountKey sAcnt
   cid <- lookupCurrency sCurrency
   sign <- lookupAccountSign sAcnt
@@ -571,7 +600,7 @@ resolveSplit s@Split {sAcnt, sCurrency, sValue, sTags} = do
   -- TODO correct sign here?
   -- TODO lenses would be nice here
   return $
-    (concatEithers2 (concatEither3 aid cid sign (,,)) $ concatEitherL tags) $
+    concatEithers2 (concatEither3 aid cid sign (,,)) (concatEitherL tags) $
       \(aid_, cid_, sign_) tags_ ->
         s
           { sAcnt = aid_
@@ -586,16 +615,16 @@ insertTx c Tx {txDate = d, txDescr = e, txSplits = ss} = do
   mapM_ (insertSplit k) ss
 
 insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m (Key SplitR)
-insertSplit t Split {sAcnt, sCurrency, sValue, sComment, sTags} = do
+insertSplit t Entry {sAcnt, sCurrency, sValue, sComment, sTags} = do
   k <- insert $ SplitR t sCurrency sAcnt sComment sValue
   mapM_ (insert_ . TagRelationR k) sTags
   return k
 
 lookupAccount :: MonadFinance m => AcntID -> m (EitherErr (Key AccountR, AcntSign, AcntType))
-lookupAccount p = lookupErr (DBKey AcntField) p <$> (askDBState kmAccount)
+lookupAccount p = lookupErr (DBKey AcntField) p <$> askDBState kmAccount
 
 lookupAccountKey :: MonadFinance m => AcntID -> m (EitherErr (Key AccountR))
-lookupAccountKey = (fmap (fmap fstOf3)) . lookupAccount
+lookupAccountKey = fmap (fmap fstOf3) . lookupAccount
 
 lookupAccountSign :: MonadFinance m => AcntID -> m (EitherErr AcntSign)
 lookupAccountSign = fmap (fmap sndOf3) . lookupAccount
@@ -604,10 +633,10 @@ lookupAccountType :: MonadFinance m => AcntID -> m (EitherErr AcntType)
 lookupAccountType = fmap (fmap thdOf3) . lookupAccount
 
 lookupCurrency :: MonadFinance m => T.Text -> m (EitherErr (Key CurrencyR))
-lookupCurrency c = lookupErr (DBKey CurField) c <$> (askDBState kmCurrency)
+lookupCurrency c = lookupErr (DBKey CurField) c <$> askDBState kmCurrency
 
 lookupTag :: MonadFinance m => TagID -> m (EitherErr (Key TagR))
-lookupTag c = lookupErr (DBKey TagField) c <$> (askDBState kmTag)
+lookupTag c = lookupErr (DBKey TagField) c <$> askDBState kmTag
 
 -- TODO this hashes twice (not that it really matters)
 whenHash

lib/Internal/Statement.hs

@@ -19,8 +19,8 @@ import qualified RIO.Vector as V
 
 -- TODO this probably won't scale well (pipes?)
 
-readImport :: MonadFinance m => Import -> m (EitherErrs [BalTx])
+readImport :: MonadFinance m => Statement -> m (EitherErrs [BalTx])
-readImport Import {..} = do
+readImport Statement {..} = do
   let ores = plural $ compileOptions impTxOpts
   let cres = concatEithersL $ compileMatch <$> impMatches
   case concatEithers2 ores cres (,) of
@@ -219,7 +219,7 @@ balanceSplits ss =
     $ groupByKey
     $ fmap (\s -> (sCurrency s, s)) ss
   where
-    hasValue s@(Split {sValue = Just v}) = Right s {sValue = v}
+    hasValue s@Entry {sValue = Just v} = Right s {sValue = v}
     hasValue s = Left s
     bal cur rss
       | length rss < 2 = Left $ BalanceError TooFewSplits cur rss

lib/Internal/Types.hs

@@ -33,33 +33,38 @@ makeHaskellTypesWith
   , MultipleConstructors "WeekdayPat" "(./dhall/Types.dhall).WeekdayPat"
   , MultipleConstructors "MDYPat" "(./dhall/Types.dhall).MDYPat"
   , MultipleConstructors "DatePat" "(./dhall/Types.dhall).DatePat"
-  , MultipleConstructors "MatchYMD" "(./dhall/Types.dhall).MatchYMD"
+  , MultipleConstructors "YMDMatcher" "(./dhall/Types.dhall).YMDMatcher"
-  , MultipleConstructors "MatchDate" "(./dhall/Types.dhall).MatchDate"
+  , MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher"
-  , MultipleConstructors "SplitNum" "(./dhall/Types.dhall).SplitNum"
+  , MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter"
-  , MultipleConstructors "AmountType" "(./dhall/Types.dhall).AmountType"
   , MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
+  , MultipleConstructors "BudgetTransferType" "(./dhall/Types.dhall).BudgetTransferType"
+  , MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod"
   , SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
   , SingleConstructor "Tag" "Tag" "(./dhall/Types.dhall).Tag"
+  , SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt"
   , SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
   , SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
   , SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval"
-  , SingleConstructor "Global" "Global" "(./dhall/Types.dhall).Global"
+  , SingleConstructor "TemporalScope" "TemporalScope" "(./dhall/Types.dhall).TemporalScope"
   , SingleConstructor "RepeatPat" "RepeatPat" "(./dhall/Types.dhall).RepeatPat"
   , SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type"
   , SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.Type"
   , SingleConstructor "Decimal" "D" "(./dhall/Types.dhall).Decimal"
-  , SingleConstructor "MatchVal" "MatchVal" "(./dhall/Types.dhall).MatchVal.Type"
+  , SingleConstructor "ValMatcher" "ValMatcher" "(./dhall/Types.dhall).ValMatcher.Type"
-  , SingleConstructor "Manual" "Manual" "(./dhall/Types.dhall).Manual"
   , SingleConstructor "Amount" "Amount" "(./dhall/Types.dhall).Amount"
-  , SingleConstructor "TimeAmount" "TimeAmount" "(./dhall/Types.dhall).TimeAmount"
-  , SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt"
   , SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type"
-  , SingleConstructor "ShadowMatch" "ShadowMatch" "(./dhall/Types.dhall).ShadowMatch.Type"
+  , 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 "Split" "Split" "(./dhall/Types.dhall).Split"
+  , SingleConstructor "Entry" "Entry" "(./dhall/Types.dhall).Entry"
+  , SingleConstructor "PretaxValue" "PretaxValue" "(./dhall/Types.dhall).PretaxValue"
+  , SingleConstructor "TaxBracket" "TaxBracket" "(./dhall/Types.dhall).TaxBracket"
+  , SingleConstructor "TaxProgression" "TaxProgression" "(./dhall/Types.dhall).TaxProgression"
+  , SingleConstructor "TaxValue" "TaxValue" "(./dhall/Types.dhall).TaxValue"
+  , SingleConstructor "PosttaxValue" "PosttaxValue" "(./dhall/Types.dhall).PosttaxValue"
+  , SingleConstructor "BudgetTransferValue" "BudgetTransferValue" "(./dhall/Types.dhall).BudgetTransferValue"
   -- , SingleConstructor "ToTx" "ToTx" "(./dhall/Types.dhall).ToTx"
   -- , SingleConstructor "MatchOther" "MatchOther" "(./dhall/Types.dhall).MatchOther_"
   -- , SingleConstructor "Match" "Match" "(./dhall/Types.dhall).Match_"
@@ -86,21 +91,25 @@ deriveProduct
   , "Budget"
   , "Income"
   , "ShadowTransfer"
-  , "ShadowMatch"
+  , "TransferMatcher"
   , "AcntSet"
-  , "MatchDate"
+  , "DateMatcher"
-  , "MatchVal"
+  , "ValMatcher"
-  , "MatchYMD"
+  , "YMDMatcher"
   , "Decimal"
-  , "Transfer"
   , "BudgetCurrency"
-  , "Manual"
   , "Exchange"
-  , "Amount"
+  , "EntryNumGetter"
-  , "AmountType"
+  , "TemporalScope"
-  , "SplitNum"
-  , "Global"
   , "SqlConfig"
+  , "PretaxValue"
+  , "TaxValue"
+  , "TaxBracket"
+  , "TaxProgression"
+  , "TaxMethod"
+  , "PosttaxValue"
+  , "BudgetTransferValue"
+  , "BudgetTransferType"
   ]
 
 -------------------------------------------------------------------------------
@@ -168,18 +177,37 @@ deriving instance Ord DatePat
 
 deriving instance Hashable DatePat
 
+type BudgetTransfer =
+  Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue
+
 data Budget = Budget
   { budgetLabel :: Text
   , incomes :: [Income]
-  , pretax :: [IntervalAllocation]
+  , pretax :: [MultiAllocation PretaxValue]
-  , tax :: [IntervalAllocation]
+  , tax :: [MultiAllocation TaxValue]
-  , posttax :: [IntervalAllocation]
+  , posttax :: [MultiAllocation PosttaxValue]
-  , transfers :: [Transfer]
+  , transfers :: [BudgetTransfer]
   , shadowTransfers :: [ShadowTransfer]
   }
 
+deriving instance Hashable PretaxValue
+
+deriving instance Hashable TaxBracket
+
+deriving instance Hashable TaxProgression
+
+deriving instance Hashable TaxMethod
+
+deriving instance Hashable TaxValue
+
+deriving instance Hashable PosttaxValue
+
 deriving instance Hashable Budget
 
+deriving instance Hashable BudgetTransferValue
+
+deriving instance Hashable BudgetTransferType
+
 deriving instance Hashable TaggedAcnt
 
 deriving instance Ord TaggedAcnt
@@ -190,35 +218,49 @@ data Income = Income
   { incGross :: Decimal
   , incCurrency :: CurID
   , incWhen :: DatePat
-  , incPretax :: [Allocation]
+  , incPretax :: [SingleAllocation PretaxValue]
-  , incTaxes :: [Allocation]
+  , incTaxes :: [SingleAllocation TaxValue]
-  , incPosttax :: [Allocation]
+  , incPosttax :: [SingleAllocation PosttaxValue]
   , incFrom :: TaggedAcnt
   , incToBal :: TaggedAcnt
   }
 
 deriving instance Hashable Income
 
-deriving instance Ord Amount
+deriving instance (Ord w, Ord v) => Ord (Amount w v)
 
-deriving instance Hashable Amount
+deriving instance Generic (Amount w v)
+
+deriving instance (Generic w, Generic v, FromDhall w, FromDhall v) => FromDhall (Amount w v)
+
+deriving instance (Generic w, Generic v, Hashable w, Hashable v) => Hashable (Amount w v)
+
+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 BudgetCurrency
 
-data Allocation_ a = Allocation_
+data Allocation w v = Allocation
   { alloTo :: TaggedAcnt
-  , alloAmts :: [a]
+  , alloAmts :: [Amount w v]
-  , alloCur :: BudgetCurrency
+  , alloCur :: CurID
   }
   deriving (Eq, Show, Generic, Hashable)
 
-deriving instance FromDhall a => FromDhall (Allocation_ a)
+instance Bifunctor Amount where
+  bimap f g a@Amount {amtWhen, amtValue} = a {amtWhen = f amtWhen, amtValue = g amtValue}
 
-type Allocation = Allocation_ Amount
+instance Bifunctor Allocation where
+  bimap f g a@Allocation {alloAmts} = a {alloAmts = fmap (bimap f g) alloAmts}
 
-type IntervalAllocation = Allocation_ IntervalAmount
+deriving instance (Generic w, Generic v, FromDhall w, FromDhall v) => FromDhall (Allocation w v)
+
+type MultiAllocation = Allocation Interval
+
+type SingleAllocation = Allocation ()
 
 toPersistText :: Show a => a -> PersistValue
 toPersistText = PersistText . T.pack . show
@@ -230,68 +272,38 @@ fromPersistText what (PersistText t) = case readMaybe $ T.unpack t of
 fromPersistText what x =
   Left $ T.unwords ["error when deserializing", what, "; got", T.pack (show x)]
 
-deriving instance Ord AmountType
-
-deriving instance Hashable AmountType
-
--- data TimeAmount a = TimeAmount
---   { taWhen :: a
---   , taAmt :: Amount
---   , taAmtType :: AmountType
---   }
---   deriving (Show, Eq, Ord, Functor, Generic, FromDhall, Hashable, Foldable, Traversable)
-
-deriving instance Show a => Show (TimeAmount a)
-
-deriving instance Eq a => Eq (TimeAmount a)
-
-deriving instance Ord a => Ord (TimeAmount a)
-
-deriving instance Functor TimeAmount
-
-deriving instance Foldable TimeAmount
-
-deriving instance Traversable TimeAmount
-
-deriving instance Generic (TimeAmount a)
-
-deriving instance Hashable a => Hashable (TimeAmount a)
-
-deriving instance FromDhall a => FromDhall (TimeAmount a)
-
-type DateAmount = TimeAmount DatePat
-
-type IntervalAmount = TimeAmount Interval
-
 deriving instance Ord Interval
 
-data Transfer = Transfer
+data Transfer a c w v = Transfer
-  { transFrom :: TaggedAcnt
+  { transFrom :: a
-  , transTo :: TaggedAcnt
+  , transTo :: a
-  , transAmounts :: [DateAmount]
+  , transAmounts :: [Amount w v]
-  , transCurrency :: BudgetCurrency
+  , transCurrency :: c
   }
+  deriving (Eq, Show, Generic, FromDhall)
 
-deriving instance Hashable Transfer
+deriving instance
+  (Generic w, Generic v, Hashable a, Hashable c, Hashable w, Hashable v)
+  => Hashable (Transfer a c w v)
 
 deriving instance Hashable ShadowTransfer
 
 deriving instance Hashable AcntSet
 
-deriving instance Hashable ShadowMatch
+deriving instance Hashable TransferMatcher
 
-deriving instance Hashable MatchVal
+deriving instance Hashable ValMatcher
 
-deriving instance Hashable MatchYMD
+deriving instance Hashable YMDMatcher
 
-deriving instance Hashable MatchDate
+deriving instance Hashable DateMatcher
 
 deriving instance Ord Decimal
 
 deriving instance Hashable Decimal
 
 -- TODO this just looks silly...but not sure how to simplify it
-instance Ord MatchYMD where
+instance Ord YMDMatcher where
   compare (Y y) (Y y') = compare y y'
   compare (YM g) (YM g') = compare g g'
   compare (YMD g) (YMD g') = compare g g'
@@ -306,15 +318,13 @@ gregM :: Gregorian -> GregorianM
 gregM Gregorian {gYear = y, gMonth = m} =
   GregorianM {gmYear = y, gmMonth = m}
 
-instance Ord MatchDate where
+instance Ord DateMatcher where
   compare (On d) (On d') = compare d d'
   compare (In d r) (In d' r') = compare d d' <> compare r r'
   compare (On d) (In d' _) = compare d d' <> LT
   compare (In d _) (On d') = compare d d' <> GT
 
-deriving instance Hashable SplitNum
+deriving instance Hashable EntryNumGetter
-
-deriving instance Hashable Manual
 
 -------------------------------------------------------------------------------
 -- top level type with fixed account tree to unroll the recursion in the dhall
@@ -347,10 +357,10 @@ deriving instance FromDhall AccountRootF
 type AccountRoot = AccountRoot_ AccountTree
 
 data Config_ a = Config_
-  { global :: !Global
+  { global :: !TemporalScope
   , budget :: ![Budget]
   , currencies :: ![Currency]
-  , statements :: ![Statement]
+  , statements :: ![History]
   , accounts :: !a
   , tags :: ![Tag]
   , sqlConfig :: !SqlConfig
@@ -384,22 +394,24 @@ type AcntID = T.Text
 
 type TagID = T.Text
 
-data Statement
+type HistTransfer = Transfer AcntID CurID DatePat Decimal
-  = StmtManual !Manual
+
-  | StmtImport !Import
+data History
+  = HistTransfer !HistTransfer
+  | HistStatement !Statement
   deriving (Eq, Hashable, Generic, FromDhall)
 
-type ExpSplit = Split SplitAcnt (Maybe SplitNum) SplitCur TagID
+type ExpSplit = Entry SplitAcnt (Maybe EntryNumGetter) SplitCur TagID
 
 instance FromDhall ExpSplit
 
-deriving instance (Show a, Show c, Show v, Show t) => Show (Split a v c t)
+deriving instance (Show a, Show c, Show v, Show t) => Show (Entry a v c t)
 
-deriving instance Generic (Split a v c t)
+deriving instance Generic (Entry a v c t)
 
-deriving instance (Hashable a, Hashable v, Hashable c, Hashable t) => Hashable (Split a v c t)
+deriving instance (Hashable a, Hashable v, Hashable c, Hashable t) => Hashable (Entry a v c t)
 
-deriving instance (Eq a, Eq v, Eq c, Eq t) => Eq (Split a v c t)
+deriving instance (Eq a, Eq v, Eq c, Eq t) => Eq (Entry a v c t)
 
 data Tx s = Tx
   { txDescr :: !T.Text
@@ -422,7 +434,7 @@ data TxOpts re = TxOpts
   }
   deriving (Eq, Generic, Hashable, Show, FromDhall)
 
-data Import = Import
+data Statement = Statement
   { impPaths :: ![FilePath]
   , impMatches :: ![Match T.Text]
   , impDelim :: !Word
@@ -466,7 +478,7 @@ type FieldMap k v = Field k (M.Map k v)
 
 data MatchOther re
   = Desc !(Field T.Text re)
-  | Val !(Field T.Text MatchVal)
+  | Val !(Field T.Text ValMatcher)
   deriving (Eq, Hashable, Generic, FromDhall, Functor, Foldable, Traversable)
 
 deriving instance Show (MatchOther T.Text)
@@ -479,8 +491,8 @@ data ToTx = ToTx
   deriving (Eq, Generic, Hashable, Show, FromDhall)
 
 data Match re = Match
-  { mDate :: !(Maybe MatchDate)
+  { mDate :: !(Maybe DateMatcher)
-  , mVal :: !MatchVal
+  , mVal :: !ValMatcher
   , mDesc :: !(Maybe re)
   , mOther :: ![MatchOther re]
   , mTx :: !(Maybe ToTx)
@@ -583,7 +595,7 @@ data DBState = DBState
 
 type MappingT m = ReaderT DBState (SqlPersistT m)
 
-type KeySplit = Split AccountRId Rational CurrencyRId TagRId
+type KeySplit = Entry AccountRId Rational CurrencyRId TagRId
 
 type KeyTx = Tx KeySplit
 
@@ -676,9 +688,9 @@ accountSign IncomeT = Credit
 accountSign LiabilityT = Credit
 accountSign EquityT = Credit
 
-type RawSplit = Split AcntID (Maybe Rational) CurID TagID
+type RawSplit = Entry AcntID (Maybe Rational) CurID TagID
 
-type BalSplit = Split AcntID Rational CurID TagID
+type BalSplit = Entry AcntID Rational CurID TagID
 
 type RawTx = Tx RawSplit
 
@@ -720,7 +732,7 @@ data InsertError
   | ConversionError !T.Text
   | LookupError !LookupSuberr !T.Text
   | BalanceError !BalanceType !CurID ![RawSplit]
-  | IncomeError !DatePat
+  | IncomeError !Day !T.Text !Rational
   | PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
   | BoundsError !Gregorian !(Maybe Gregorian)
   | StatementError ![TxRecord] ![MatchRe]

lib/Internal/Utils.hs

@@ -97,22 +97,22 @@ gregMTup GregorianM {gmYear, gmMonth} =
 
 data YMD_ = Y_ !Integer | YM_ !Integer !Int | YMD_ !Integer !Int !Int
 
-fromMatchYMD :: MatchYMD -> YMD_
+fromYMDMatcher :: YMDMatcher -> YMD_
-fromMatchYMD m = case m of
+fromYMDMatcher m = case m of
   Y y -> Y_ $ fromIntegral y
   YM g -> uncurry YM_ $ gregMTup g
   YMD g -> uncurry3 YMD_ $ gregTup g
 
-compareDate :: MatchDate -> Day -> Ordering
+compareDate :: DateMatcher -> Day -> Ordering
 compareDate (On md) x =
-  case fromMatchYMD md of
+  case fromYMDMatcher md of
     Y_ y' -> compare y y'
     YM_ y' m' -> compare (y, m) (y', m')
     YMD_ y' m' d' -> compare (y, m, d) (y', m', d')
   where
     (y, m, d) = toGregorian x
 compareDate (In md offset) x = do
-  case fromMatchYMD md of
+  case fromYMDMatcher md of
     Y_ y' -> compareRange y' y
     YM_ y' m' -> compareRange (toMonth y' m') $ toMonth y m
     YMD_ y' m' d' ->
@@ -172,7 +172,7 @@ toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> EitherErrs RawTx
 toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} =
   concatEithers2 acRes ssRes $ \(a_, c_) ss_ ->
     let fromSplit =
-          Split
+          Entry
             { sAcnt = a_
             , sCurrency = c_
             , sValue = Just trAmount
@@ -188,8 +188,8 @@ toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} =
     acRes = concatEithers2 (resolveAcnt r sa) (resolveCurrency r sc) (,)
     ssRes = concatEithersL $ fmap (resolveSplit r) toSplits
 
-valMatches :: MatchVal -> Rational -> EitherErr Bool
+valMatches :: ValMatcher -> Rational -> EitherErr Bool
-valMatches MatchVal {mvDen, mvSign, mvNum, mvPrec} x
+valMatches ValMatcher {mvDen, mvSign, mvNum, mvPrec} x
   | Just d_ <- mvDen, d_ >= p = Left $ MatchValPrecisionError d_ p
   | otherwise =
       Right $
@@ -202,7 +202,7 @@ valMatches MatchVal {mvDen, mvSign, mvNum, mvPrec} x
     s = signum x >= 0
     checkMaybe = maybe True
 
-dateMatches :: MatchDate -> Day -> Bool
+dateMatches :: DateMatcher -> Day -> Bool
 dateMatches md = (EQ ==) . compareDate md
 
 otherMatches :: M.Map T.Text T.Text -> MatchOtherRe -> EitherErr Bool
@@ -213,14 +213,14 @@ otherMatches dict m = case m of
     lookup_ t n = lookupErr (MatchField t) n dict
 
 resolveSplit :: TxRecord -> ExpSplit -> EitherErrs RawSplit
-resolveSplit r s@Split {sAcnt = a, sValue = v, sCurrency = c} =
+resolveSplit r s@Entry {sAcnt = a, sValue = v, sCurrency = c} =
   concatEithers2 acRes valRes $
     \(a_, c_) v_ -> (s {sAcnt = a_, sValue = v_, sCurrency = c_})
   where
     acRes = concatEithers2 (resolveAcnt r a) (resolveCurrency r c) (,)
     valRes = plural $ mapM (resolveValue r) v
 
-resolveValue :: TxRecord -> SplitNum -> EitherErr Rational
+resolveValue :: TxRecord -> EntryNumGetter -> EitherErr Rational
 resolveValue r s = case s of
   (LookupN t) -> readRational =<< lookupErr SplitValField t (trOther r)
   (ConstN c) -> Right $ dec2Rat c
@@ -371,8 +371,16 @@ showError other = case other of
       idName TagField = "tag"
       matchName MatchNumeric = "numeric"
       matchName MatchText = "text"
-  (IncomeError dp) ->
+  (IncomeError day name balance) ->
-    [T.append "Income allocations exceed total: datepattern=" $ showT dp]
+    [ T.unwords
+        [ "Income allocations for budget"
+        , singleQuote name
+        , "exceed total on day"
+        , showT day
+        , "where balance is"
+        , showT balance
+        ]
+    ]
   (BalanceError t cur rss) ->
     [ T.unwords
         [ msg
@@ -406,8 +414,8 @@ showMatch Match {mDate = d, mVal = v, mDesc = e, mOther = o, mTimes = n, mPriori
   T.append "Unused match: " $ keyVals [(x, y) | (x, Just y) <- kvs]
   where
     kvs =
-      [ ("date", showMatchDate <$> d)
+      [ ("date", showDateMatcher <$> d)
-      , ("val", showMatchVal v)
+      , ("val", showValMatcher v)
       , ("desc", fst <$> e)
       , ("other", others)
       , ("counter", Just $ maybe "Inf" showT n)
@@ -420,14 +428,14 @@ showMatch Match {mDate = d, mVal = v, mDesc = e, mOther = o, mTimes = n, mPriori
 -- | Convert match date to text
 -- Single date matches will just show the single date, and ranged matches will
 -- show an interval like [YY-MM-DD, YY-MM-DD)
-showMatchDate :: MatchDate -> T.Text
+showDateMatcher :: DateMatcher -> T.Text
-showMatchDate md = case md of
+showDateMatcher md = case md of
-  (On x) -> showMatchYMD x
+  (On x) -> showYMDMatcher x
-  (In start n) -> T.concat ["[", showMatchYMD start, " ", showYMD_ end, ")"]
+  (In start n) -> T.concat ["[", showYMDMatcher start, " ", showYMD_ end, ")"]
     where
       -- TODO not DRY (this shifting thing happens during the comparison
       -- function (kinda)
-      end = case fromMatchYMD start of
+      end = case fromYMDMatcher start of
         Y_ y -> Y_ $ y + fromIntegral n
         YM_ y m ->
           let (y_, m_) = divMod (m + fromIntegral n - 1) 12
@@ -439,8 +447,8 @@ showMatchDate md = case md of
                 fromGregorian y m d
 
 -- | convert YMD match to text
-showMatchYMD :: MatchYMD -> T.Text
+showYMDMatcher :: YMDMatcher -> T.Text
-showMatchYMD = showYMD_ . fromMatchYMD
+showYMDMatcher = showYMD_ . fromYMDMatcher
 
 showYMD_ :: YMD_ -> T.Text
 showYMD_ md =
@@ -451,9 +459,9 @@ showYMD_ md =
       YM_ y m -> [fromIntegral y, m]
       YMD_ y m d -> [fromIntegral y, m, d]
 
-showMatchVal :: MatchVal -> Maybe T.Text
+showValMatcher :: ValMatcher -> Maybe T.Text
-showMatchVal MatchVal {mvSign = Nothing, mvNum = Nothing, mvDen = Nothing} = Nothing
+showValMatcher ValMatcher {mvSign = Nothing, mvNum = Nothing, mvDen = Nothing} = Nothing
-showMatchVal MatchVal {mvNum, mvDen, mvSign, mvPrec} =
+showValMatcher ValMatcher {mvNum, mvDen, mvSign, mvPrec} =
   Just $ singleQuote $ keyVals [(k, v) | (k, Just v) <- kvs]
   where
     kvs =
@@ -471,11 +479,11 @@ showMatchOther (Val (Field f mv)) =
     [ "val field"
     , singleQuote f
     , "with match value"
-    , singleQuote $ fromMaybe "*" $ showMatchVal mv
+    , singleQuote $ fromMaybe "*" $ showValMatcher mv
     ]
 
 showSplit :: RawSplit -> T.Text
-showSplit Split {sAcnt = a, sValue = v, sComment = c} =
+showSplit Entry {sAcnt = a, sValue = v, sComment = c} =
   keyVals
     [ ("account", a)
     , ("value", T.pack $ show ((fromRational <$> v) :: Maybe Float))