Merge branch 'add_budget_limits'

app/Main.hs

@@ -8,10 +8,11 @@ import Control.Monad.Logger
 import Control.Monad.Reader
 import qualified Data.Text.IO as TI
 import Database.Persist.Monad
-import Internal.Config
+import Dhall hiding (double, record)
-import Internal.Database.Ops
+import Internal.Budget
-import Internal.Insert
+import Internal.Database
-import Internal.Types
+import Internal.History
+import Internal.Types.Main
 import Internal.Utils
 import Options.Applicative
 import RIO
@@ -168,25 +169,31 @@ runSync c = do
     -- _ <- askLoggerIO
 
     -- get the current DB state
-    s <- runSqlQueryT pool $ do
+    (state, updates) <- runSqlQueryT pool $ do
       runMigration migrateAll
-      fmap (\f -> f $ takeDirectory c) $ liftIOExceptT $ getDBState config
+      liftIOExceptT $ getDBState config
 
     -- read desired statements from disk
-    bSs <- flip runReaderT s $ catMaybes <$> mapErrorsIO readHistStmt hSs
+    bSs <-
+      flip runReaderT state $
+        catMaybes <$> mapErrorsIO (readHistStmt root) hSs
 
     -- update the DB
-    runSqlQueryT pool $ withTransaction $ flip runReaderT s $ do
+    runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
       let hTransRes = mapErrors insertHistTransfer hTs
       let bgtRes = mapErrors insertBudget $ budget config
-      updateDBState -- TODO this will only work if foreign keys are deferred
+      updateDBState updates -- TODO this will only work if foreign keys are deferred
       res <- runExceptT $ do
         mapM_ (uncurry insertHistStmt) bSs
         combineError hTransRes bgtRes $ \_ _ -> ()
       rerunnableIO $ fromEither res
   where
+    root = takeDirectory c
     err (InsertException es) = do
       liftIO $ mapM_ TI.putStrLn $ concatMap showError es
       exitFailure
 
 -- showBalances
+
+readConfig :: MonadUnliftIO m => FilePath -> m Config
+readConfig confpath = liftIO $ unfix <$> Dhall.inputFile Dhall.auto confpath

budget.cabal

@@ -25,12 +25,13 @@ source-repository head
 
 library
   exposed-modules:
-      Internal.Config
+      Internal.Budget
-      Internal.Database.Ops
+      Internal.Database
-      Internal.Insert
+      Internal.History
-      Internal.Statement
+      Internal.Types.Database
-      Internal.TH
+      Internal.Types.Dhall
-      Internal.Types
+      Internal.Types.Main
+      Internal.Types.TH
       Internal.Utils
   other-modules:
       Paths_budget

dhall/Types.dhall

@@ -1018,6 +1018,7 @@ let Budget =
       , bgtPosttax : List (MultiAllocation PosttaxValue)
       , bgtTransfers : List BudgetTransfer
       , bgtShadowTransfers : List ShadowTransfer
+      , bgtInterval : Optional Interval
       }
 
 in  { CurID

lib/Internal/Budget.hs

@@ -0,0 +1,570 @@
+module Internal.Budget (insertBudget) where
+
+import Control.Monad.Except
+import Data.Foldable
+import Database.Persist.Monad
+import Internal.Database
+import Internal.Types.Main
+import Internal.Utils
+import RIO hiding (to)
+import qualified RIO.List as L
+import qualified RIO.Map as M
+import qualified RIO.NonEmpty as NE
+import qualified RIO.Text as T
+import RIO.Time
+
+-- 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
+-- 5. insert all transactions
+
+insertBudget
+  :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
+  => Budget
+  -> m ()
+insertBudget
+  b@Budget
+    { bgtLabel
+    , bgtIncomes
+    , bgtTransfers
+    , bgtShadowTransfers
+    , bgtPretax
+    , bgtTax
+    , bgtPosttax
+    , bgtInterval
+    } =
+    whenHash CTBudget b () $ \key -> do
+      (intAllos, _) <- combineError intAlloRes acntRes (,)
+      let res1 = mapErrors (insertIncome key bgtLabel intAllos bgtInterval) bgtIncomes
+      let res2 = expandTransfers key bgtLabel bgtInterval bgtTransfers
+      txs <- combineError (concat <$> res1) res2 (++)
+      m <- askDBState kmCurrency
+      shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs
+      void $ mapErrors insertBudgetTx $ balanceTransfers $ txs ++ shadow
+    where
+      acntRes = mapErrors isNotIncomeAcnt alloAcnts
+      intAlloRes = combineError3 pre_ tax_ post_ (,,)
+      pre_ = sortAllos bgtPretax
+      tax_ = sortAllos bgtTax
+      post_ = sortAllos bgtPosttax
+      sortAllos = liftExcept . mapErrors sortAllo
+      alloAcnts =
+        (alloAcnt <$> bgtPretax)
+          ++ (alloAcnt <$> bgtTax)
+          ++ (alloAcnt <$> bgtPosttax)
+
+balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer]
+balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen
+  where
+    go bals f@FlatTransfer {ftFrom, ftTo, ftValue = UnbalancedValue {cvValue, cvType}} =
+      let balTo = M.findWithDefault 0 ftTo bals
+          x = amtToMove balTo cvType cvValue
+          bals' = mapAdd_ ftTo x $ mapAdd_ ftFrom (-x) bals
+       in (bals', f {ftValue = x})
+    -- TODO might need to query signs to make this intuitive; as it is this will
+    -- probably work, but for credit accounts I might need to supply a negative
+    -- target value
+    amtToMove _ BTFixed x = x
+    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
+
+insertBudgetTx
+  :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
+  => BalancedTransfer
+  -> m ()
+insertBudgetTx FlatTransfer {ftFrom, ftTo, ftMeta, ftCur, ftValue, ftDesc, ftWhen} = do
+  ((sFrom, sTo), exchange) <- entryPair ftFrom ftTo ftCur ftValue
+  insertPair sFrom sTo
+  forM_ exchange $ uncurry insertPair
+  where
+    insertPair from to = do
+      k <- insert $ TransactionR (bmCommit ftMeta) ftWhen ftDesc
+      insertBudgetLabel k from
+      insertBudgetLabel k to
+    insertBudgetLabel k entry = do
+      sk <- insertEntry k entry
+      insert_ $ BudgetLabelR sk $ bmName ftMeta
+
+entryPair
+  :: (MonadInsertError m, MonadFinance m)
+  => TaggedAcnt
+  -> TaggedAcnt
+  -> BudgetCurrency
+  -> Rational
+  -> m (EntryPair, Maybe EntryPair)
+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 = entry curid from_ (-v)
+      let s2 = entry curid to_ v
+      combineError s1 s2 (,)
+    entry c TaggedAcnt {taAcnt, taTags} v =
+      resolveEntry $
+        Entry
+          { eAcnt = taAcnt
+          , eValue = v
+          , eComment = ""
+          , eCurrency = c
+          , eTags = taTags
+          }
+
+sortAllo :: MultiAllocation v -> InsertExcept (DaySpanAllocation v)
+sortAllo a@Allocation {alloAmts = as} = do
+  bs <- foldSpan [] $ L.sortOn amtWhen as
+  return $ a {alloAmts = reverse bs}
+  where
+    foldSpan acc [] = return acc
+    foldSpan acc (x : xs) = do
+      let start = amtWhen x
+      res <- case xs of
+        [] -> resolveDaySpan start
+        (y : _) -> resolveDaySpan_ (intStart $ amtWhen y) start
+      foldSpan (x {amtWhen = res} : acc) xs
+
+--------------------------------------------------------------------------------
+-- Income
+
+-- TODO this will scan the interval allocations fully each time
+-- iteration which is a total waste, but the fix requires turning this
+-- loop into a fold which I don't feel like doing now :(
+insertIncome
+  :: (MonadInsertError m, MonadFinance m)
+  => CommitRId
+  -> T.Text
+  -> IntAllocations
+  -> Maybe Interval
+  -> Income
+  -> m [UnbalancedTransfer]
+insertIncome
+  key
+  name
+  (intPre, intTax, intPost)
+  localInterval
+  Income
+    { incWhen
+    , incCurrency
+    , incFrom
+    , incPretax
+    , incPosttax
+    , incTaxes
+    , incToBal
+    , incGross
+    , incPayPeriod
+    } =
+    combineErrorM
+      (combineError incRes nonIncRes (,))
+      (combineError precRes dayRes (,))
+      $ \_ (precision, days) -> do
+        let gross = roundPrecision precision incGross
+        concat <$> foldDays (allocate precision gross) start days
+    where
+      incRes = isIncomeAcnt $ taAcnt incFrom
+      nonIncRes =
+        mapErrors isNotIncomeAcnt $
+          taAcnt incToBal
+            : (alloAcnt <$> incPretax)
+            ++ (alloAcnt <$> incTaxes)
+            ++ (alloAcnt <$> incPosttax)
+      precRes = lookupCurrencyPrec incCurrency
+      dayRes = askDays incWhen localInterval
+      start = fromGregorian' $ pStart incPayPeriod
+      pType' = pType incPayPeriod
+      meta = BudgetMeta key name
+      flatPre = concatMap flattenAllo incPretax
+      flatTax = concatMap flattenAllo incTaxes
+      flatPost = concatMap flattenAllo incPosttax
+      sumAllos = sum . fmap faValue
+      -- TODO ensure these are all the "correct" accounts
+      allocate precision gross prevDay day = do
+        scaler <- liftExcept $ periodScaler pType' prevDay day
+        let (preDeductions, pre) =
+              allocatePre precision gross $
+                flatPre ++ concatMap (selectAllos day) intPre
+            tax =
+              allocateTax precision gross preDeductions scaler $
+                flatTax ++ concatMap (selectAllos day) intTax
+            aftertaxGross = gross - sumAllos (tax ++ pre)
+            post =
+              allocatePost precision aftertaxGross $
+                flatPost ++ concatMap (selectAllos day) intPost
+            balance = aftertaxGross - sumAllos post
+            bal =
+              FlatTransfer
+                { ftMeta = meta
+                , ftWhen = day
+                , ftFrom = incFrom
+                , ftCur = NoX incCurrency
+                , ftTo = incToBal
+                , ftValue = UnbalancedValue BTFixed balance
+                , ftDesc = "balance after deductions"
+                }
+         in if balance < 0
+              then throwError $ InsertException [IncomeError day name balance]
+              else return (bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post))
+
+periodScaler
+  :: PeriodType
+  -> Day
+  -> Day
+  -> InsertExcept PeriodScaler
+periodScaler pt prev cur = return scale
+  where
+    n = fromIntegral $ workingDays wds prev cur
+    wds = case pt of
+      Hourly HourlyPeriod {hpWorkingDays} -> hpWorkingDays
+      Daily ds -> ds
+    scale precision x = case pt of
+      Hourly HourlyPeriod {hpAnnualHours, hpDailyHours} ->
+        fromRational (rnd $ x / fromIntegral hpAnnualHours)
+          * fromIntegral hpDailyHours
+          * n
+      Daily _ -> x * n / 365.25
+      where
+        rnd = roundPrecision precision
+
+-- ASSUME start < end
+workingDays :: [Weekday] -> Day -> Day -> Natural
+workingDays wds start end = fromIntegral $ daysFull + daysTail
+  where
+    interval = diffDays end start
+    (nFull, nPart) = divMod interval 7
+    daysFull = fromIntegral (length wds') * nFull
+    daysTail = fromIntegral $ length $ takeWhile (< nPart) wds'
+    startDay = dayOfWeek start
+    wds' = L.sort $ (\x -> diff (fromWeekday x) startDay) <$> L.nub wds
+    diff a b = fromIntegral $ mod (fromEnum a - fromEnum b) 7
+
+-- ASSUME days is a sorted list
+foldDays
+  :: MonadInsertError m
+  => (Day -> Day -> m a)
+  -> Day
+  -> [Day]
+  -> m [a]
+foldDays f start days = case NE.nonEmpty days of
+  Nothing -> return []
+  Just ds
+    | any (start >) ds ->
+        throwError $
+          InsertException [PeriodError start $ minimum ds]
+    | otherwise ->
+        combineErrors $
+          snd $
+            L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days
+
+isIncomeAcnt :: (MonadInsertError m, MonadFinance m) => AcntID -> m ()
+isIncomeAcnt = checkAcntType IncomeT
+
+isNotIncomeAcnt :: (MonadInsertError m, MonadFinance m) => AcntID -> m ()
+isNotIncomeAcnt = checkAcntTypes (AssetT :| [EquityT, ExpenseT, LiabilityT])
+
+checkAcntType
+  :: (MonadInsertError m, MonadFinance m)
+  => AcntType
+  -> AcntID
+  -> m ()
+checkAcntType t = checkAcntTypes (t :| [])
+
+checkAcntTypes
+  :: (MonadInsertError m, MonadFinance m)
+  => NE.NonEmpty AcntType
+  -> AcntID
+  -> m ()
+checkAcntTypes ts i = void $ go =<< lookupAccountType i
+  where
+    go t
+      | t `L.elem` ts = return i
+      | otherwise = throwError $ InsertException [AccountError i ts]
+
+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
+        }
+
+-- 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
+  -> Day
+  -> TaggedAcnt
+  -> FlatAllocation Rational
+  -> UnbalancedTransfer
+allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} =
+  FlatTransfer
+    { ftMeta = meta
+    , ftWhen = day
+    , ftFrom = from
+    , ftCur = faCur
+    , ftTo = faTo
+    , ftValue = UnbalancedValue BTFixed faValue
+    , 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
+  -> M.Map T.Text Rational
+  -> PeriodScaler
+  -> [FlatAllocation TaxValue]
+  -> [FlatAllocation Rational]
+allocateTax precision gross preDeds f = fmap (fmap go)
+  where
+    go TaxValue {tvCategories, tvMethod} =
+      let agi = gross - sum (mapMaybe (`M.lookup` preDeds) tvCategories)
+       in case tvMethod of
+            TMPercent p ->
+              roundPrecision precision $
+                fromRational $
+                  roundPrecision 3 p / 100 * agi
+            TMBracket TaxProgression {tpDeductible, tpBrackets} ->
+              let taxDed = roundPrecision precision $ f precision tpDeductible
+               in foldBracket f precision (agi - taxDed) tpBrackets
+
+-- | 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
+--    than the bracket limit
+-- 2. Computing the tax in the top bracket by subtracting the AGI from the
+--    bracket limit and multiplying by the tax percentage.
+-- 3. Adding all lower brackets, which are just the limit of the bracket less
+--    the amount of the lower bracket times the percentage.
+--
+-- In reality, this can all be done with one loop, but it isn't clear these
+-- three steps are implemented from this alone.
+foldBracket :: PeriodScaler -> Natural -> Rational -> [TaxBracket] -> Rational
+foldBracket f precision agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
+  where
+    go TaxBracket {tbLowerLimit, tbPercent} a@(acc, remain) =
+      let l = roundPrecision precision $ f precision tbLowerLimit
+          p = roundPrecision 3 tbPercent / 100
+       in if remain >= l then (acc + p * (remain - l), l) else a
+
+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
+
+--------------------------------------------------------------------------------
+-- Standalone Transfer
+
+expandTransfers
+  :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
+  => CommitRId
+  -> T.Text
+  -> Maybe Interval
+  -> [BudgetTransfer]
+  -> m [UnbalancedTransfer]
+expandTransfers key name localInterval ts = do
+  txs <-
+    fmap (L.sortOn ftWhen . concat) $
+      combineErrors $
+        fmap (expandTransfer key name) ts
+  case localInterval of
+    Nothing -> return txs
+    Just i -> do
+      bounds <- liftExcept $ resolveDaySpan i
+      return $ filter (inDaySpan bounds . ftWhen) txs
+
+expandTransfer
+  :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
+  => CommitRId
+  -> T.Text
+  -> BudgetTransfer
+  -> m [UnbalancedTransfer]
+expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = do
+  precision <- lookupCurrencyPrec $ initialCurrency transCurrency
+  fmap concat $ combineErrors $ fmap (go precision) transAmounts
+  where
+    go
+      precision
+      Amount
+        { amtWhen = pat
+        , amtValue = BudgetTransferValue {btVal = v, btType = y}
+        , amtDesc = desc
+        } =
+        withDates pat $ \day -> do
+          let meta = BudgetMeta {bmCommit = key, bmName = name}
+          return
+            FlatTransfer
+              { ftMeta = meta
+              , ftWhen = day
+              , ftCur = transCurrency
+              , ftFrom = transFrom
+              , ftTo = transTo
+              , ftValue = UnbalancedValue y $ roundPrecision precision v
+              , ftDesc = desc
+              }
+
+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
+
+--------------------------------------------------------------------------------
+-- 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
+    memberMaybe x AcntSet {asList, asInclude} =
+      (if asInclude then id else not) $ x `elem` asList
+
+--------------------------------------------------------------------------------
+-- random
+
+initialCurrency :: BudgetCurrency -> CurID
+initialCurrency (NoX c) = c
+initialCurrency (X Exchange {xFromCur = c}) = c
+
+alloAcnt :: Allocation w v -> AcntID
+alloAcnt = taAcnt . alloTo
+
+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 EntryPair = (KeyEntry, KeyEntry)
+
+type PeriodScaler = Natural -> Double -> Double
+
+data FlatAllocation v = FlatAllocation
+  { faValue :: !v
+  , faDesc :: !T.Text
+  , faTo :: !TaggedAcnt
+  , faCur :: !BudgetCurrency
+  }
+  deriving (Functor, Show)

lib/Internal/Config.hs

@@ -1,21 +0,0 @@
-module Internal.Config
-  ( readConfig
-  -- , readYaml
-  )
-where
-
--- import Control.Exception
--- import Data.Yaml
-import Dhall hiding (record)
-import Internal.Types
-import RIO
-
-readConfig :: MonadUnliftIO m => FilePath -> m Config
-readConfig confpath = liftIO $ unfix <$> inputFile auto confpath
-
--- readYaml :: FromJSON a => FilePath -> IO a
--- readYaml p = do
---   r <- decodeFileEither p
---   case r of
---     Right a -> return a
---     Left e -> throw e

lib/Internal/Database.hs

@@ -1,4 +1,4 @@
-module Internal.Database.Ops
+module Internal.Database
   ( runDB
   , nukeTables
   , updateHashes
@@ -8,6 +8,10 @@ module Internal.Database.Ops
   , flattenAcntRoot
   , paths2IDs
   , mkPool
+  , whenHash
+  , whenHash_
+  , insertEntry
+  , resolveEntry
   )
 where
 
@@ -19,10 +23,18 @@ import Database.Esqueleto.Experimental ((==.), (^.))
 import qualified Database.Esqueleto.Experimental as E
 import Database.Esqueleto.Internal.Internal (SqlSelect)
 import Database.Persist.Monad
--- import Database.Persist.Sql hiding (delete, runMigration, (==.), (||.))
+import Database.Persist.Sqlite hiding
-import Database.Persist.Sqlite hiding (delete, deleteWhere, insert, insertKey, runMigration, (==.), (||.))
+  ( delete
+  , deleteWhere
+  , insert
+  , insertKey
+  , insert_
+  , runMigration
+  , (==.)
+  , (||.)
+  )
 import GHC.Err
-import Internal.Types
+import Internal.Types.Main
 import Internal.Utils
 import RIO hiding (LogFunc, isNothing, on, (^.))
 import RIO.List ((\\))
@@ -288,79 +300,117 @@ indexAcntRoot r =
 getDBState
   :: (MonadInsertError m, MonadSqlQuery m)
   => Config
-  -> m (FilePath -> DBState)
+  -> m (DBState, DBUpdates)
 getDBState c = do
   (del, new) <- getConfigHashes c
-  -- TODO not sure how I feel about this, probably will change this struct alot
+  combineError bi si $ \b s ->
-  -- in the future so whatever...for now
+    ( DBState
-  combineError bi si $ \b s f ->
+        { kmCurrency = currencyMap cs
-    -- TODO this can be cleaned up, half of it is meant to be queried when
+        , kmAccount = am
-    -- determining how to insert budgets/history and the rest is just
+        , kmBudgetInterval = b
-    -- holdover data to delete upon successful insertion
+        , kmStatementInterval = s
-    DBState
+        , kmTag = tagMap ts
-      { kmCurrency = currencyMap cs
+        , kmNewCommits = new
-      , kmAccount = am
+        }
-      , kmBudgetInterval = b
+    , DBUpdates
-      , kmStatementInterval = s
+        { duOldCommits = del
-      , kmNewCommits = new
+        , duNewTagIds = ts
-      , kmOldCommits = del
+        , duNewAcntPaths = paths
-      , kmConfigDir = f
+        , duNewAcntIds = acnts
-      , kmTag = tagMap ts
+        , duNewCurrencyIds = cs
-      , kmTagAll = ts
+        }
-      , kmAcntPaths = paths
+    )
-      , kmAcntsOld = acnts
-      , 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
     toRecord t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc
     tagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
 
-updateHashes :: (MonadFinance m, MonadSqlQuery m) => m ()
+updateHashes :: (MonadSqlQuery m) => DBUpdates -> m ()
-updateHashes = do
+updateHashes DBUpdates {duOldCommits} = nukeDBHashes duOldCommits
-  old <- askDBState kmOldCommits
-  nukeDBHashes old
 
-updateTags :: (MonadFinance m, MonadSqlQuery m) => m ()
+updateTags :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
-updateTags = do
+updateTags DBUpdates {duNewTagIds} = do
-  tags <- askDBState kmTagAll
   tags' <- selectE $ E.from $ E.table @TagR
-  let (toIns, toDel) = setDiff tags tags'
+  let (toIns, toDel) = setDiff duNewTagIds tags'
   mapM_ deleteTag toDel
   mapM_ insertFull toIns
 
-updateAccounts :: (MonadFinance m, MonadSqlQuery m) => m ()
+updateAccounts :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
-updateAccounts = do
+updateAccounts DBUpdates {duNewAcntIds, duNewAcntPaths} = do
-  acnts <- askDBState kmAcntsOld
-  paths <- askDBState kmAcntPaths
   acnts' <- dumpTbl
-  let (toIns, toDel) = setDiff acnts acnts'
+  let (toIns, toDel) = setDiff duNewAcntIds acnts'
   deleteWhere ([] :: [Filter AccountPathR])
   mapM_ deleteAccount toDel
   mapM_ insertFull toIns
-  mapM_ insert paths
+  mapM_ insert duNewAcntPaths
 
-updateCurrencies :: (MonadFinance m, MonadSqlQuery m) => m ()
+updateCurrencies :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
-updateCurrencies = do
+updateCurrencies DBUpdates {duNewCurrencyIds} = do
-  curs <- askDBState kmCurrenciesOld
   curs' <- selectE $ E.from $ E.table @CurrencyR
-  let (toIns, toDel) = setDiff curs curs'
+  let (toIns, toDel) = setDiff duNewCurrencyIds curs'
   mapM_ deleteCurrency toDel
   mapM_ insertFull toIns
 
-updateDBState :: (MonadFinance m, MonadSqlQuery m) => m ()
+updateDBState :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
-updateDBState = do
+updateDBState u = do
-  updateHashes
+  updateHashes u
-  updateTags
+  updateTags u
-  updateAccounts
+  updateAccounts u
-  updateCurrencies
+  updateCurrencies u
 
 deleteE :: (MonadSqlQuery m) => E.SqlQuery () -> m ()
 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
+
+insertEntry :: MonadSqlQuery m => TransactionRId -> KeyEntry -> m EntryRId
+insertEntry t Entry {eAcnt, eCurrency, eValue, eComment, eTags} = do
+  k <- insert $ EntryR t eCurrency eAcnt eComment eValue
+  mapM_ (insert_ . TagRelationR k) eTags
+  return k
+
+resolveEntry :: (MonadInsertError m, MonadFinance m) => BalEntry -> m KeyEntry
+resolveEntry 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

@@ -1,16 +1,18 @@
-{-# LANGUAGE RecordWildCards #-}
+module Internal.History
-
+  ( splitHistory
-module Internal.Statement
+  , insertHistTransfer
-  ( readImport
+  , readHistStmt
+  , insertHistStmt
   )
 where
 
-import Control.Monad.Error.Class
 import Control.Monad.Except
 import Data.Csv
-import Internal.Types
+import Database.Persist.Monad
+import Internal.Database
+import Internal.Types.Main
 import Internal.Utils
-import RIO
+import RIO hiding (to)
 import qualified RIO.ByteString.Lazy as BL
 import RIO.FilePath
 import qualified RIO.List as L
@@ -19,30 +21,118 @@ import qualified RIO.Text as T
 import RIO.Time
 import qualified RIO.Vector as V
 
+splitHistory :: [History] -> ([HistTransfer], [Statement])
+splitHistory = partitionEithers . fmap go
+  where
+    go (HistTransfer x) = Left x
+    go (HistStatement x) = Right x
+
+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)
+  => FilePath
+  -> Statement
+  -> m (Maybe (CommitR, [KeyTx]))
+readHistStmt root i = whenHash_ CTImport i $ do
+  bs <- readImport root 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
+
+--------------------------------------------------------------------------------
+-- 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
+        , txEntries = [split from (-val), split to val]
+        }
+
+resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx
+resolveTx t@Tx {txEntries = ss} =
+  fmap (\kss -> t {txEntries = kss}) $
+    combineErrors $
+      fmap resolveEntry ss
+
+insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m ()
+insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do
+  k <- insert $ TransactionR c d e
+  mapM_ (insertEntry k) ss
+
+--------------------------------------------------------------------------------
+-- Statements
+
 -- TODO this probably won't scale well (pipes?)
-readImport :: (MonadUnliftIO m, MonadFinance m) => Statement -> m [BalTx]
+readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [BalTx]
-readImport Statement {..} = do
+readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
   let ores = compileOptions stmtTxOpts
   let cres = combineErrors $ compileMatch <$> stmtParsers
   (compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,)
   let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions
-  records <- L.sort . concat <$> mapErrorsIO readStmt stmtPaths
+  records <- L.sort . concat <$> mapErrorsIO readStmt paths
   m <- askDBState kmCurrency
   fromEither $
     flip runReader m $
       runExceptT $
         matchRecords compiledMatches records
+  where
+    paths = (root </>) <$> stmtPaths
 
 readImport_
-  :: (MonadUnliftIO m, MonadFinance m)
+  :: MonadUnliftIO m
   => Natural
   -> Word
   -> TxOptsRe
   -> FilePath
   -> m [TxRecord]
 readImport_ n delim tns p = do
-  dir <- askDBState kmConfigDir
+  res <- tryIO $ BL.readFile p
-  res <- tryIO $ BL.readFile $ dir </> p
   bs <- fromEither $ first (InsertException . (: []) . InsertIOError . showT) res
   case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
     Left m -> throwIO $ InsertException [ParseError $ T.pack m]
@@ -54,7 +144,7 @@ readImport_ n delim tns p = do
 -- TODO handle this better, this maybe thing is a hack to skip lines with
 -- blank dates but will likely want to make this more flexible
 parseTxRecord :: FilePath -> TxOptsRe -> NamedRecord -> Parser (Maybe TxRecord)
-parseTxRecord p TxOpts {..} r = do
+parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFmt} r = do
   d <- r .: T.encodeUtf8 toDate
   if d == ""
     then return Nothing
@@ -69,7 +159,6 @@ matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [BalTx]
 matchRecords ms rs = do
   (matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
   case (matched, unmatched, notfound) of
-    -- TODO record number of times each match hits for debugging
     (ms_, [], []) -> liftInner $ combineErrors $ fmap balanceTx ms_
     (_, us, ns) -> throwError $ InsertException [StatementError us ns]
 
@@ -85,7 +174,6 @@ matchToGroup ms =
     first (L.sortOn spDate) $
       L.partition (isJust . spDate) ms
 
--- TDOO could use a better struct to flatten the maybe date subtype
 data MatchGroup = MatchGroup
   { mgDate :: ![MatchRe]
   , mgNoDate :: ![MatchRe]
@@ -141,7 +229,6 @@ zipperMatch (Unzipped bs cs as) x = go [] cs
               ms' = maybe ms (: ms) (matchDec m)
            in return (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
 
--- TODO all this unpacking left/error crap is annoying
 zipperMatch'
   :: Zipped MatchRe
   -> TxRecord
@@ -217,12 +304,12 @@ matchNonDates ms = go ([], [], initZipper ms)
        in go (m, u, resetZipper z') rs
 
 balanceTx :: RawTx -> InsertExcept BalTx
-balanceTx t@Tx {txSplits = ss} = do
+balanceTx t@Tx {txEntries = ss} = do
-  bs <- balanceSplits ss
+  bs <- balanceEntries ss
-  return $ t {txSplits = bs}
+  return $ t {txEntries = bs}
 
-balanceSplits :: [RawSplit] -> InsertExcept [BalSplit]
+balanceEntries :: [RawEntry] -> InsertExcept [BalEntry]
-balanceSplits ss =
+balanceEntries ss =
   fmap concat
     <$> mapM (uncurry bal)
     $ groupByKey
@@ -231,7 +318,7 @@ balanceSplits ss =
     haeValue s@Entry {eValue = Just v} = Right s {eValue = v}
     haeValue s = Left s
     bal cur rss
-      | length rss < 2 = throwError $ InsertException [BalanceError TooFewSplits cur rss]
+      | length rss < 2 = throwError $ InsertException [BalanceError TooFewEntries cur rss]
       | otherwise = case partitionEithers $ fmap haeValue rss of
           ([noVal], val) -> return $ noVal {eValue = foldr (\s x -> x - eValue s) 0 val} : val
           ([], val) -> return val

lib/Internal/Insert.hs

@@ -1,789 +0,0 @@
-module Internal.Insert
-  ( insertBudget
-  , splitHistory
-  , insertHistTransfer
-  , readHistStmt
-  , insertHistStmt
-  )
-where
-
-import Control.Monad.Except
-import Data.Hashable
-import Database.Persist.Monad
-import Internal.Statement
-import Internal.Types
-import Internal.Utils
-import RIO hiding (to)
-import qualified RIO.List as L
-import qualified RIO.Map as M
-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
-
-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
-
-foldDates
-  :: (MonadSqlQuery m, MonadFinance m, MonadInsertError m)
-  => DatePat
-  -> Day
-  -> (Day -> Day -> m a)
-  -> m [a]
-foldDates dp start f = do
-  bounds <- askDBState kmBudgetInterval
-  days <- liftExcept $ expandDatePat bounds dp
-  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
-  -> m ()
-insertBudget
-  b@Budget
-    { bgtLabel
-    , bgtIncomes
-    , bgtTransfers
-    , bgtShadowTransfers
-    , bgtPretax
-    , bgtTax
-    , bgtPosttax
-    } =
-    whenHash CTBudget b () $ \key -> do
-      intAllos <- combineError3 pre_ tax_ post_ (,,)
-      let res1 = mapErrors (insertIncome key bgtLabel intAllos) bgtIncomes
-      let res2 = expandTransfers key bgtLabel bgtTransfers
-      txs <- combineError (concat <$> res1) res2 (++)
-      m <- askDBState kmCurrency
-      shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs
-      void $ mapErrors insertBudgetTx $ balanceTransfers $ txs ++ shadow
-    where
-      pre_ = sortAllos bgtPretax
-      tax_ = sortAllos bgtTax
-      post_ = sortAllos bgtPosttax
-      sortAllos = liftExcept . combineErrors . fmap sortAllo
-
-type BoundAllocation = Allocation (Day, Day)
-
-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 = expandBounds 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 $
-          -- TODO does this actually share the same metadata as the "parent" tx?
-          FlatTransfer
-            { cbtMeta = cbtMeta tx
-            , cbtWhen = cbtWhen tx
-            , cbtCur = stCurrency
-            , cbtFrom = stFrom
-            , cbtTo = stTo
-            , cbtValue = UnbalancedValue stType $ v * cvValue (cbtValue tx)
-            , cbtDesc = stDesc
-            }
-
-shadowMatches :: TransferMatcher -> UnbalancedTransfer -> InsertExcept Bool
-shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do
-  valRes <- valMatches tmVal $ cvValue $ cbtValue tx
-  return $
-    memberMaybe (taAcnt $ cbtFrom tx) tmFrom
-      && memberMaybe (taAcnt $ cbtTo tx) tmTo
-      && maybe True (`dateMatches` cbtWhen tx) tmDate
-      && valRes
-  where
-    memberMaybe x AcntSet {asList, asInclude} =
-      (if asInclude then id else not) $ x `elem` asList
-
-balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer]
-balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn cbtWhen
-  where
-    go bals f@FlatTransfer {cbtFrom, cbtTo, cbtValue = UnbalancedValue {cvValue, cvType}} =
-      let balTo = M.findWithDefault 0 cbtTo bals
-          x = amtToMove balTo cvType cvValue
-          bals' = mapAdd_ cbtTo x $ mapAdd_ cbtFrom (-x) bals
-       in (bals', f {cbtValue = 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 _ BTFixed x = x
-    amtToMove bal BTPercent x = -(x / 100 * 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.alter (maybe (Just v) (Just . (+ v))) k
-
-data BudgetMeta = BudgetMeta
-  { bmCommit :: !CommitRId
-  , bmName :: !T.Text
-  }
-  deriving (Show)
-
-data FlatTransfer v = FlatTransfer
-  { cbtFrom :: !TaggedAcnt
-  , cbtTo :: !TaggedAcnt
-  , cbtValue :: !v
-  , cbtWhen :: !Day
-  , cbtDesc :: !T.Text
-  , cbtMeta :: !BudgetMeta
-  , cbtCur :: !BudgetCurrency
-  }
-  deriving (Show)
-
-data UnbalancedValue = UnbalancedValue
-  { cvType :: !BudgetTransferType
-  , cvValue :: !Rational
-  }
-  deriving (Show)
-
-type UnbalancedTransfer = FlatTransfer UnbalancedValue
-
-type BalancedTransfer = FlatTransfer Rational
-
-insertIncome
-  :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
-  => CommitRId
-  -> T.Text
-  -> IntAllocations
-  -> Income
-  -> m [UnbalancedTransfer]
-insertIncome
-  key
-  name
-  (intPre, intTax, intPost)
-  Income
-    { incWhen
-    , incCurrency
-    , incFrom
-    , incPretax
-    , incPosttax
-    , incTaxes
-    , incToBal
-    , incGross
-    , incPayPeriod
-    } = do
-    -- TODO check that the other accounts are not income somewhere here
-    _ <- checkAcntType IncomeT $ taAcnt incFrom
-    precision <- lookupCurrencyPrec incCurrency
-    let gross = roundPrecision precision incGross
-    -- TODO this will scan the interval allocations fully each time
-    -- iteration which is a total waste, but the fix requires turning this
-    -- loop into a fold which I don't feel like doing now :(
-    res <- foldDates incWhen start (allocate precision gross)
-    return $ concat res
-    where
-      start = fromGregorian' $ pStart incPayPeriod
-      pType' = pType incPayPeriod
-      meta = BudgetMeta key name
-      flatPre = concatMap flattenAllo incPretax
-      flatTax = concatMap flattenAllo incTaxes
-      flatPost = concatMap flattenAllo incPosttax
-      sumAllos = sum . fmap faValue
-      -- TODO ensure these are all the "correct" accounts
-      allocate precision gross prevDay day = do
-        scaler <- liftExcept $ periodScaler pType' prevDay day
-        let (preDeductions, pre) =
-              allocatePre precision gross $
-                flatPre ++ concatMap (selectAllos day) intPre
-            tax =
-              allocateTax precision gross preDeductions scaler $
-                flatTax ++ concatMap (selectAllos day) intTax
-            aftertaxGross = gross - sumAllos (tax ++ pre)
-            post =
-              allocatePost precision aftertaxGross $
-                flatPost ++ concatMap (selectAllos day) intPost
-            balance = aftertaxGross - sumAllos post
-            bal =
-              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 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
-  -> Day
-  -> Day
-  -> InsertExcept PeriodScaler
-periodScaler pt prev cur = do
-  n <- workingDays wds prev cur
-  return $ scale (fromIntegral n)
-  where
-    wds = case pt of
-      Hourly HourlyPeriod {hpWorkingDays} -> hpWorkingDays
-      Daily ds -> ds
-    scale n precision x = case pt of
-      Hourly HourlyPeriod {hpAnnualHours, hpDailyHours} ->
-        fromRational (rnd $ x / fromIntegral hpAnnualHours)
-          * fromIntegral hpDailyHours
-          * n
-      Daily _ -> x * n / 365.25
-      where
-        rnd = roundPrecision precision
-
-workingDays :: [Weekday] -> Day -> Day -> InsertExcept Natural
-workingDays wds start end
-  | interval > 0 =
-      let (nFull, nPart) = divMod interval 7
-          daysFull = fromIntegral (length wds') * nFull
-          daysTail = fromIntegral $ length $ takeWhile (< nPart) wds'
-       in return $ fromIntegral $ daysFull + daysTail
-  | otherwise = throwError $ InsertException undefined
-  where
-    interval = diffDays end start
-    startDay = dayOfWeek start
-    wds' = L.sort $ (\x -> diff (fromWeekday x) startDay) <$> L.nub wds
-    diff a b = fromIntegral $ mod (fromEnum a - fromEnum b) 7
-
-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})
-
-allo2Trans
-  :: BudgetMeta
-  -> Day
-  -> TaggedAcnt
-  -> FlatAllocation Rational
-  -> UnbalancedTransfer
-allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} =
-  FlatTransfer
-    { cbtMeta = meta
-    , cbtWhen = day
-    , cbtFrom = from
-    , cbtCur = faCur
-    , cbtTo = faTo
-    , cbtValue = UnbalancedValue BTFixed faValue
-    , cbtDesc = faDesc
-    }
-
-allocateTax
-  :: Natural
-  -> Rational
-  -> M.Map T.Text Rational
-  -> PeriodScaler
-  -> [FlatAllocation TaxValue]
-  -> [FlatAllocation Rational]
-allocateTax precision gross preDeds f = fmap (fmap go)
-  where
-    go TaxValue {tvCategories, tvMethod} =
-      let agi = gross - sum (mapMaybe (`M.lookup` preDeds) tvCategories)
-       in case tvMethod of
-            TMPercent p ->
-              roundPrecision precision $
-                fromRational $
-                  roundPrecision 3 p / 100 * agi
-            TMBracket TaxProgression {tpDeductible, tpBrackets} ->
-              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
---    than the bracket limit
--- 2. Computing the tax in the top bracket by subtracting the AGI from the
---    bracket limit and multiplying by the tax percentage.
--- 3. Adding all lower brackets, which are just the limit of the bracket less
---    the amount of the lower bracket times the percentage.
---
--- In reality, this can all be done with one loop, but it isn't clear these
--- three steps are implemented from this alone.
-foldBracket :: PeriodScaler -> Natural -> Rational -> [TaxBracket] -> Rational
-foldBracket f precision agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
-  where
-    go TaxBracket {tbLowerLimit, tbPercent} a@(acc, remain) =
-      let l = roundPrecision precision $ f precision tbLowerLimit
-          p = roundPrecision 3 tbPercent / 100
-       in if remain >= l then (acc + p * (remain - l), l) else a
-
-data FlatAllocation v = FlatAllocation
-  { faValue :: !v
-  , faDesc :: !T.Text
-  , faTo :: !TaggedAcnt
-  , faCur :: !BudgetCurrency
-  }
-  deriving (Functor, Show)
-
-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
-        }
-
--- ASSUME allocations are sorted
-selectAllos :: Day -> BoundAllocation v -> [FlatAllocation v]
-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)
-  => CommitRId
-  -> T.Text
-  -> [BudgetTransfer]
-  -> m [UnbalancedTransfer]
-expandTransfers key name ts =
-  fmap (L.sortOn cbtWhen . concat) $
-    combineErrors $
-      fmap (expandTransfer key name) ts
-
-initialCurrency :: BudgetCurrency -> CurID
-initialCurrency (NoX c) = c
-initialCurrency (X Exchange {xFromCur = c}) = c
-
-expandTransfer
-  :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
-  => CommitRId
-  -> T.Text
-  -> BudgetTransfer
-  -> m [UnbalancedTransfer]
-expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = do
-  precision <- lookupCurrencyPrec $ initialCurrency transCurrency
-  fmap concat $ combineErrors $ fmap (go precision) transAmounts
-  where
-    go
-      precision
-      Amount
-        { amtWhen = pat
-        , amtValue = BudgetTransferValue {btVal = v, btType = y}
-        , amtDesc = desc
-        } =
-        withDates pat $ \day -> do
-          let meta = BudgetMeta {bmCommit = key, bmName = name}
-          return
-            FlatTransfer
-              { cbtMeta = meta
-              , cbtWhen = day
-              , cbtCur = transCurrency
-              , cbtFrom = transFrom
-              , cbtTo = transTo
-              , cbtValue = UnbalancedValue y $ roundPrecision precision v
-              , cbtDesc = desc
-              }
-
-insertBudgetTx :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) => BalancedTransfer -> m ()
-insertBudgetTx FlatTransfer {cbtFrom, cbtTo, cbtMeta, cbtCur, cbtValue, cbtDesc, cbtWhen} = do
-  ((sFrom, sTo), exchange) <- splitPair cbtFrom cbtTo cbtCur cbtValue
-  insertPair sFrom sTo
-  forM_ exchange $ uncurry insertPair
-  where
-    insertPair from to = do
-      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 cbtMeta
-
-type SplitPair = (KeySplit, KeySplit)
-
-splitPair
-  :: (MonadInsertError m, MonadFinance m)
-  => TaggedAcnt
-  -> TaggedAcnt
-  -> BudgetCurrency
-  -> Rational
-  -> m (SplitPair, Maybe SplitPair)
-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
-          }
-
-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 <- expandBounds <$> 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/Types/Database.hs

@@ -0,0 +1,75 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- | Types corresponding to the database model
+module Internal.Types.Database where
+
+import Database.Persist.Sql hiding (Desc, In, Statement)
+import Database.Persist.TH
+import RIO
+import qualified RIO.Text as T
+import RIO.Time
+
+share
+  [mkPersist sqlSettings, mkMigrate "migrateAll"]
+  [persistLowerCase|
+CommitR sql=commits
+    hash Int
+    type ConfigType
+    deriving Show Eq
+CurrencyR sql=currencies
+    symbol T.Text
+    fullname T.Text
+    precision Int
+    deriving Show Eq
+TagR sql=tags
+    symbol T.Text
+    fullname T.Text
+    deriving Show Eq
+AccountR sql=accounts
+    name T.Text
+    fullpath T.Text
+    desc T.Text
+    deriving Show Eq
+AccountPathR sql=account_paths
+    parent AccountRId OnDeleteCascade
+    child AccountRId OnDeleteCascade
+    depth Int
+    deriving Show Eq
+TransactionR sql=transactions
+    commit CommitRId OnDeleteCascade
+    date Day
+    description T.Text
+    deriving Show Eq
+EntryR sql=entries
+    transaction TransactionRId OnDeleteCascade
+    currency CurrencyRId OnDeleteCascade
+    account AccountRId OnDeleteCascade
+    memo T.Text
+    value Rational
+    deriving Show Eq
+TagRelationR sql=tag_relations
+    entry EntryRId OnDeleteCascade
+    tag TagRId OnDeleteCascade
+BudgetLabelR sql=budget_labels
+    entry EntryRId OnDeleteCascade
+    budgetName T.Text
+    deriving Show Eq
+|]
+
+data ConfigType = CTBudget | CTManual | CTImport
+  deriving (Eq, Show, Read, Enum)
+
+instance PersistFieldSql ConfigType where
+  sqlType _ = SqlString
+
+instance PersistField ConfigType where
+  toPersistValue = PersistText . T.pack . show
+
+  -- TODO these error messages *might* be good enough?
+  fromPersistValue (PersistText v) =
+    maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v
+  fromPersistValue _ = Left "wrong type"

lib/Internal/Types/Dhall.hs

@@ -4,29 +4,24 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE UndecidableInstances #-}
 
-module Internal.Types where
+-- | Types corresponding to the configuration tree (written in Dhall)
+module Internal.Types.Dhall where
 
 import Control.Monad.Except
 import Data.Fix (Fix (..), foldFix)
 import Data.Functor.Foldable (embed)
 import qualified Data.Functor.Foldable.TH as TH
 import Database.Persist.Sql hiding (Desc, In, Statement)
-import Database.Persist.TH
 import Dhall hiding (embed, maybe)
 import Dhall.TH
-import Internal.TH (deriveProduct)
+import Internal.Types.TH (deriveProduct)
 import Language.Haskell.TH.Syntax (Lift)
 import RIO
 import qualified RIO.Map as M
-import qualified RIO.NonEmpty as NE
 import qualified RIO.Text as T
 import RIO.Time
 import Text.Regex.TDFA
 
--------------------------------------------------------------------------------
--- DHALL CONFIG
--------------------------------------------------------------------------------
-
 makeHaskellTypesWith
   (defaultGenerateOptions {generateToDhallInstance = False, generateFromDhallInstance = False})
   [ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig"
@@ -200,6 +195,7 @@ data Budget = Budget
   , bgtPosttax :: [MultiAllocation PosttaxValue]
   , bgtTransfers :: [BudgetTransfer]
   , bgtShadowTransfers :: [ShadowTransfer]
+  , bgtInterval :: !(Maybe Interval)
   }
 
 deriving instance Hashable PretaxValue
@@ -425,7 +421,7 @@ data History
   | HistStatement !Statement
   deriving (Eq, Generic, Hashable, FromDhall)
 
-type EntryGetter = Entry SplitAcnt (Maybe EntryNumGetter) SplitCur TagID
+type EntryGetter = Entry EntryAcnt (Maybe EntryNumGetter) EntryCur TagID
 
 instance FromDhall EntryGetter
 
@@ -440,7 +436,7 @@ deriving instance (Eq a, Eq v, Eq c, Eq t) => Eq (Entry a v c t)
 data Tx s = Tx
   { txDescr :: !T.Text
   , txDate :: !Day
-  , txSplits :: ![s]
+  , txEntries :: ![s]
   }
   deriving (Generic)
 
@@ -467,7 +463,7 @@ data Statement = Statement
   }
   deriving (Eq, Hashable, Generic, FromDhall)
 
--- | the value of a field in split (text version)
+-- | the value of a field in entry (text version)
 -- can either be a raw (constant) value, a lookup from the record, or a map
 -- between the lookup and some other value
 data EntryTextGetter t
@@ -477,9 +473,9 @@ data EntryTextGetter t
   | Map2T !(FieldMap (T.Text, T.Text) t)
   deriving (Eq, Generic, Hashable, Show, FromDhall)
 
-type SplitCur = EntryTextGetter CurID
+type EntryCur = EntryTextGetter CurID
 
-type SplitAcnt = EntryTextGetter AcntID
+type EntryAcnt = EntryTextGetter AcntID
 
 deriving instance (Show k, Show v) => Show (Field k v)
 
@@ -508,8 +504,8 @@ data FieldMatcher re
 deriving instance Show (FieldMatcher T.Text)
 
 data TxGetter = TxGetter
-  { tgCurrency :: !SplitCur
+  { tgCurrency :: !EntryCur
-  , tgAcnt :: !SplitAcnt
+  , tgAcnt :: !EntryAcnt
   , tgEntries :: ![EntryGetter]
   }
   deriving (Eq, Generic, Hashable, Show, FromDhall)
@@ -527,270 +523,5 @@ data StatementParser re = StatementParser
 
 deriving instance Show (StatementParser T.Text)
 
---------------------------------------------------------------------------------
--- DATABASE MODEL
---------------------------------------------------------------------------------
-
-share
-  [mkPersist sqlSettings, mkMigrate "migrateAll"]
-  [persistLowerCase|
-CommitR sql=commits
-    hash Int
-    type ConfigType
-    deriving Show Eq
-CurrencyR sql=currencies
-    symbol T.Text
-    fullname T.Text
-    precision Int
-    deriving Show Eq
-TagR sql=tags
-    symbol T.Text
-    fullname T.Text
-    deriving Show Eq
-AccountR sql=accounts
-    name T.Text
-    fullpath T.Text
-    desc T.Text
-    deriving Show Eq
-AccountPathR sql=account_paths
-    parent AccountRId OnDeleteCascade
-    child AccountRId OnDeleteCascade
-    depth Int
-    deriving Show Eq
-TransactionR sql=transactions
-    commit CommitRId OnDeleteCascade
-    date Day
-    description T.Text
-    deriving Show Eq
-SplitR sql=splits
-    transaction TransactionRId OnDeleteCascade
-    currency CurrencyRId OnDeleteCascade
-    account AccountRId OnDeleteCascade
-    memo T.Text
-    value Rational
-    deriving Show Eq
-TagRelationR sql=tag_relations
-    split SplitRId OnDeleteCascade
-    tag TagRId OnDeleteCascade
-BudgetLabelR sql=budget_labels
-    split SplitRId OnDeleteCascade
-    budgetName T.Text
-    deriving Show Eq
-|]
-
---------------------------------------------------------------------------------
--- database cache types
-
-data ConfigHashes = ConfigHashes
-  { chIncome :: ![Int]
-  , chExpense :: ![Int]
-  , chManual :: ![Int]
-  , chImport :: ![Int]
-  }
-
-data ConfigType = CTBudget | CTManual | CTImport
-  deriving (Eq, Show, Read, Enum)
-
-instance PersistFieldSql ConfigType where
-  sqlType _ = SqlString
-
-instance PersistField ConfigType where
-  toPersistValue = PersistText . T.pack . show
-
-  -- TODO these error messages *might* be good enough?
-  fromPersistValue (PersistText v) =
-    maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v
-  fromPersistValue _ = Left "wrong type"
-
-type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
-
-type CurrencyMap = M.Map CurID (CurrencyRId, Natural)
-
-type TagMap = M.Map TagID TagRId
-
-data DBState = DBState
-  { kmCurrency :: !CurrencyMap
-  , kmAccount :: !AccountMap
-  , kmTag :: !TagMap
-  , kmBudgetInterval :: !Bounds
-  , kmStatementInterval :: !Bounds
-  , kmNewCommits :: ![Int]
-  , kmOldCommits :: ![Int]
-  , kmConfigDir :: !FilePath
-  , kmTagAll :: ![Entity TagR]
-  , kmAcntPaths :: ![AccountPathR]
-  , kmAcntsOld :: ![Entity AccountR]
-  , kmCurrenciesOld :: ![Entity CurrencyR]
-  }
-
-type CurrencyM = Reader CurrencyMap
-
-type KeySplit = Entry AccountRId Rational CurrencyRId TagRId
-
-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
-
-data AcntType
-  = AssetT
-  | EquityT
-  | ExpenseT
-  | IncomeT
-  | LiabilityT
-  deriving (Show, Eq, Ord, Lift, Hashable, Generic, Read, FromDhall)
-
-atName :: AcntType -> T.Text
-atName AssetT = "asset"
-atName EquityT = "equity"
-atName ExpenseT = "expense"
-atName IncomeT = "income"
-atName LiabilityT = "liability"
-
-data AcntPath = AcntPath
-  { apType :: !AcntType
-  , apChildren :: ![T.Text]
-  }
-  deriving (Eq, Ord, Show, Lift, Hashable, Generic, Read, FromDhall)
-
-data TxRecord = TxRecord
-  { trDate :: !Day
-  , trAmount :: !Rational
-  , trDesc :: !T.Text
-  , trOther :: !(M.Map T.Text T.Text)
-  , trFile :: !FilePath
-  }
-  deriving (Show, Eq, Ord)
-
-type Bounds = (Day, Natural)
-
-data Keyed a = Keyed
-  { kKey :: !Int64
-  , kVal :: !a
-  }
-  deriving (Eq, Show, Functor)
-
-data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show)
-
-data AcntSign = Credit | Debit
-  deriving (Show)
-
-sign2Int :: AcntSign -> Int
-sign2Int Debit = 1
-sign2Int Credit = 1
-
-accountSign :: AcntType -> AcntSign
-accountSign AssetT = Debit
-accountSign ExpenseT = Debit
-accountSign IncomeT = Credit
-accountSign LiabilityT = Credit
-accountSign EquityT = Credit
-
-type RawSplit = Entry AcntID (Maybe Rational) CurID TagID
-
-type BalSplit = Entry AcntID Rational CurID TagID
-
-type RawTx = Tx RawSplit
-
-type BalTx = Tx BalSplit
-
-data MatchRes a = MatchPass !a | MatchFail | MatchSkip
-
---------------------------------------------------------------------------------
--- exception types
-
-data BalanceType = TooFewSplits | NotOneBlank deriving (Show)
-
-data MatchType = MatchNumeric | MatchText deriving (Show)
-
-data SplitIDType = AcntField | CurField | TagField deriving (Show)
-
-data LookupSuberr
-  = SplitIDField !SplitIDType
-  | SplitValField
-  | MatchField !MatchType
-  | DBKey !SplitIDType
-  deriving (Show)
-
-data AllocationSuberr
-  = NoAllocations
-  | ExceededTotal
-  | MissingBlank
-  | TooManyBlanks
-  deriving (Show)
-
-data PatternSuberr = ZeroLength | ZeroRepeats deriving (Show)
-
-data InsertError
-  = RegexError !T.Text
-  | MatchValPrecisionError !Natural !Natural
-  | AccountError !AcntID !(NE.NonEmpty AcntType)
-  | InsertIOError !T.Text
-  | ParseError !T.Text
-  | ConversionError !T.Text
-  | LookupError !LookupSuberr !T.Text
-  | BalanceError !BalanceType !CurID ![RawSplit]
-  | IncomeError !Day !T.Text !Rational
-  | PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
-  | BoundsError !Gregorian !(Maybe Gregorian)
-  | StatementError ![TxRecord] ![MatchRe]
-  | PeriodError !Day !Day
-  deriving (Show)
-
-newtype InsertException = InsertException [InsertError]
-  deriving (Show, Semigroup) via [InsertError]
-
-instance Exception InsertException
-
-type MonadInsertError = MonadError InsertException
-
-type InsertExceptT = ExceptT InsertException
-
-type InsertExcept = InsertExceptT Identity
-
-data XGregorian = XGregorian
-  { xgYear :: !Int
-  , xgMonth :: !Int
-  , xgDay :: !Int
-  , xgDayOfWeek :: !Int
-  }
-
-type MatchRe = StatementParser (T.Text, Regex)
-
-type TxOptsRe = TxOpts (T.Text, Regex)
-
-type FieldMatcherRe = FieldMatcher (T.Text, Regex)
-
 instance Show (StatementParser (T.Text, Regex)) where
   show = show . fmap fst

lib/Internal/Types/Main.hs

@@ -0,0 +1,203 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- | Other types used throughout the program; kept in its own module to prevent
+-- circular imports
+module Internal.Types.Main
+  ( module Internal.Types.Main
+  , module Internal.Types.Dhall
+  , module Internal.Types.Database
+  )
+where
+
+import Control.Monad.Except
+import Database.Persist.Sql hiding (Desc, In, Statement)
+import Dhall hiding (embed, maybe)
+import Internal.Types.Database
+import Internal.Types.Dhall
+import Language.Haskell.TH.Syntax (Lift)
+import RIO
+import qualified RIO.Map as M
+import qualified RIO.NonEmpty as NE
+import qualified RIO.Text as T
+import RIO.Time
+import Text.Regex.TDFA
+
+--------------------------------------------------------------------------------
+-- database cache types
+
+data ConfigHashes = ConfigHashes
+  { chIncome :: ![Int]
+  , chExpense :: ![Int]
+  , chManual :: ![Int]
+  , chImport :: ![Int]
+  }
+
+type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
+
+type CurrencyMap = M.Map CurID (CurrencyRId, Natural)
+
+type TagMap = M.Map TagID TagRId
+
+data DBState = DBState
+  { kmCurrency :: !CurrencyMap
+  , kmAccount :: !AccountMap
+  , kmTag :: !TagMap
+  , kmBudgetInterval :: !DaySpan
+  , kmStatementInterval :: !DaySpan
+  , kmNewCommits :: ![Int]
+  }
+
+data DBUpdates = DBUpdates
+  { duOldCommits :: ![Int]
+  , duNewTagIds :: ![Entity TagR]
+  , duNewAcntPaths :: ![AccountPathR]
+  , duNewAcntIds :: ![Entity AccountR]
+  , duNewCurrencyIds :: ![Entity CurrencyR]
+  }
+
+type CurrencyM = Reader CurrencyMap
+
+type KeyEntry = Entry AccountRId Rational CurrencyRId TagRId
+
+type KeyTx = Tx KeyEntry
+
+type TreeR = Tree ([T.Text], AccountRId)
+
+type MonadFinance = MonadReader DBState
+
+askDBState :: MonadFinance m => (DBState -> a) -> m a
+askDBState = asks
+
+-------------------------------------------------------------------------------
+-- misc
+
+data AcntType
+  = AssetT
+  | EquityT
+  | ExpenseT
+  | IncomeT
+  | LiabilityT
+  deriving (Show, Eq, Ord, Lift, Hashable, Generic, Read, FromDhall)
+
+atName :: AcntType -> T.Text
+atName AssetT = "asset"
+atName EquityT = "equity"
+atName ExpenseT = "expense"
+atName IncomeT = "income"
+atName LiabilityT = "liability"
+
+data AcntPath = AcntPath
+  { apType :: !AcntType
+  , apChildren :: ![T.Text]
+  }
+  deriving (Eq, Ord, Show, Lift, Hashable, Generic, Read, FromDhall)
+
+data TxRecord = TxRecord
+  { trDate :: !Day
+  , trAmount :: !Rational
+  , trDesc :: !T.Text
+  , trOther :: !(M.Map T.Text T.Text)
+  , trFile :: !FilePath
+  }
+  deriving (Show, Eq, Ord)
+
+type DaySpan = (Day, Natural)
+
+data Keyed a = Keyed
+  { kKey :: !Int64
+  , kVal :: !a
+  }
+  deriving (Eq, Show, Functor)
+
+data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show)
+
+data AcntSign = Credit | Debit
+  deriving (Show)
+
+sign2Int :: AcntSign -> Int
+sign2Int Debit = 1
+sign2Int Credit = 1
+
+accountSign :: AcntType -> AcntSign
+accountSign AssetT = Debit
+accountSign ExpenseT = Debit
+accountSign IncomeT = Credit
+accountSign LiabilityT = Credit
+accountSign EquityT = Credit
+
+type RawEntry = Entry AcntID (Maybe Rational) CurID TagID
+
+type BalEntry = Entry AcntID Rational CurID TagID
+
+type RawTx = Tx RawEntry
+
+type BalTx = Tx BalEntry
+
+data MatchRes a = MatchPass !a | MatchFail | MatchSkip
+
+--------------------------------------------------------------------------------
+-- exception types
+
+data BalanceType = TooFewEntries | NotOneBlank deriving (Show)
+
+data MatchType = MatchNumeric | MatchText deriving (Show)
+
+data EntryIDType = AcntField | CurField | TagField deriving (Show)
+
+data LookupSuberr
+  = EntryIDField !EntryIDType
+  | EntryValField
+  | MatchField !MatchType
+  | DBKey !EntryIDType
+  deriving (Show)
+
+data AllocationSuberr
+  = NoAllocations
+  | ExceededTotal
+  | MissingBlank
+  | TooManyBlanks
+  deriving (Show)
+
+data PatternSuberr = ZeroLength | ZeroRepeats deriving (Show)
+
+data InsertError
+  = RegexError !T.Text
+  | MatchValPrecisionError !Natural !Natural
+  | AccountError !AcntID !(NE.NonEmpty AcntType)
+  | InsertIOError !T.Text
+  | ParseError !T.Text
+  | ConversionError !T.Text
+  | LookupError !LookupSuberr !T.Text
+  | BalanceError !BalanceType !CurID ![RawEntry]
+  | IncomeError !Day !T.Text !Rational
+  | PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
+  | DaySpanError !Gregorian !(Maybe Gregorian)
+  | StatementError ![TxRecord] ![MatchRe]
+  | PeriodError !Day !Day
+  deriving (Show)
+
+newtype InsertException = InsertException [InsertError]
+  deriving (Show, Semigroup) via [InsertError]
+
+instance Exception InsertException
+
+type MonadInsertError = MonadError InsertException
+
+type InsertExceptT = ExceptT InsertException
+
+type InsertExcept = InsertExceptT Identity
+
+data XGregorian = XGregorian
+  { xgYear :: !Int
+  , xgMonth :: !Int
+  , xgDay :: !Int
+  , xgDayOfWeek :: !Int
+  }
+
+type MatchRe = StatementParser (T.Text, Regex)
+
+type TxOptsRe = TxOpts (T.Text, Regex)
+
+type FieldMatcherRe = FieldMatcher (T.Text, Regex)

lib/Internal/Types/TH.hs

@@ -1,4 +1,5 @@
-module Internal.TH where
+-- | Helper functions so I don't need to write lots of dhall instances
+module Internal.Types.TH where
 
 import Language.Haskell.TH.Syntax (Dec (..), Q (..), Type (..), mkName)
 import RIO

lib/Internal/Utils.hs

@@ -1,13 +1,15 @@
 module Internal.Utils
   ( compareDate
+  , expandDatePat
+  , askDays
   , fromWeekday
-  , inBounds
+  , inDaySpan
-  , expandBounds
   , fmtRational
   , matches
   , fromGregorian'
-  , resolveBounds
+  , resolveDaySpan
-  , resolveBounds_
+  , resolveDaySpan_
+  , intersectDaySpan
   , liftInner
   , liftExceptT
   , liftExcept
@@ -26,15 +28,6 @@ module Internal.Utils
   , combineErrorIOM3
   , collectErrorsIO
   , mapErrorsIO
-  -- , leftToMaybe
-  -- , concatEithers2
-  -- , concatEithers3
-  -- , concatEither3
-  -- , concatEither2
-  -- , concatEitherL
-  -- , concatEithersL
-  -- , concatEither2M
-  -- , concatEithers2M
   , parseRational
   , showError
   , unlessLeft_
@@ -50,13 +43,18 @@ module Internal.Utils
   , sndOf3
   , thdOf3
   , xGregToDay
-  -- , plural
   , compileMatch
   , compileOptions
   , dateMatches
   , valMatches
   , roundPrecision
   , roundPrecisionCur
+  , lookupAccountKey
+  , lookupAccountSign
+  , lookupAccountType
+  , lookupCurrencyKey
+  , lookupCurrencyPrec
+  , lookupTag
   )
 where
 
@@ -65,7 +63,7 @@ import Control.Monad.Except
 import Control.Monad.Reader
 import Data.Time.Format.ISO8601
 import GHC.Real
-import Internal.Types
+import Internal.Types.Main
 import RIO
 import qualified RIO.List as L
 import qualified RIO.Map as M
@@ -75,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
 
@@ -161,27 +249,42 @@ compareDate (In md offset) x = do
 fromGregorian' :: Gregorian -> Day
 fromGregorian' = uncurry3 fromGregorian . gregTup
 
--- TODO misleading name
+inDaySpan :: DaySpan -> Day -> Bool
-inBounds :: (Day, Day) -> Day -> Bool
+inDaySpan bs = withinDays (fromDaySpan bs)
-inBounds (d0, d1) x = d0 <= x && x < d1
 
-resolveBounds :: Interval -> InsertExcept Bounds
+withinDays :: (Day, Day) -> Day -> Bool
-resolveBounds i@Interval {intStart = s} =
+withinDays (d0, d1) x = d0 <= x && x < d1
-  resolveBounds_ (s {gYear = gYear s + 50}) i
 
-resolveBounds_ :: Gregorian -> Interval -> InsertExcept Bounds
+resolveDaySpan :: Interval -> InsertExcept DaySpan
-resolveBounds_ def Interval {intStart = s, intEnd = e} =
+resolveDaySpan i@Interval {intStart = s} =
+  resolveDaySpan_ (s {gYear = gYear s + 50}) i
+
+intersectDaySpan :: DaySpan -> DaySpan -> Maybe DaySpan
+intersectDaySpan a b =
+  if b' > a' then Nothing else Just $ toDaySpan (a', b')
+  where
+    (a0, a1) = fromDaySpan a
+    (b0, b1) = fromDaySpan b
+    a' = max a0 a1
+    b' = min b0 b1
+
+resolveDaySpan_ :: Gregorian -> Interval -> InsertExcept DaySpan
+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
@@ -203,10 +306,10 @@ matches
       desc = maybe (return True) (matchMaybe trDesc . snd) spDesc
       convert (TxGetter cur a ss) = MatchPass <$> toTx cur a ss r
 
-toTx :: SplitCur -> SplitAcnt -> [EntryGetter] -> TxRecord -> InsertExceptT CurrencyM RawTx
+toTx :: EntryCur -> EntryAcnt -> [EntryGetter] -> TxRecord -> InsertExceptT CurrencyM RawTx
-toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} = do
+toTx sc sa toEntries r@TxRecord {trAmount, trDate, trDesc} = do
-  combineError3 acntRes curRes ssRes $ \a c ss ->
+  combineError3 acntRes curRes ssRes $ \a c es ->
-    let fromSplit =
+    let fromEntry =
           Entry
             { eAcnt = a
             , eCurrency = c
@@ -217,12 +320,12 @@ toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} = do
      in Tx
           { txDate = trDate
           , txDescr = trDesc
-          , txSplits = fromSplit : ss
+          , txEntries = fromEntry : es
           }
   where
     acntRes = liftInner $ resolveAcnt r sa
     curRes = liftInner $ resolveCurrency r sc
-    ssRes = combineErrors $ fmap (resolveEntry r) toSplits
+    ssRes = combineErrors $ fmap (resolveEntry r) toEntries
 
 valMatches :: ValMatcher -> Rational -> InsertExcept Bool
 valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
@@ -248,7 +351,7 @@ otherMatches dict m = case m of
   where
     lookup_ t n = lookupErr (MatchField t) n dict
 
-resolveEntry :: TxRecord -> EntryGetter -> InsertExceptT CurrencyM RawSplit
+resolveEntry :: TxRecord -> EntryGetter -> InsertExceptT CurrencyM RawEntry
 resolveEntry r s@Entry {eAcnt, eValue, eCurrency} = do
   m <- ask
   liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
@@ -344,18 +447,18 @@ collectErrorsIO = mapErrorsIO id
 
 resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept Double
 resolveValue TxRecord {trOther, trAmount} s = case s of
-  (LookupN t) -> readDouble =<< lookupErr SplitValField t trOther
+  (LookupN t) -> readDouble =<< lookupErr EntryValField t trOther
   (ConstN c) -> return c
   AmountN m -> return $ (* m) $ fromRational trAmount
 
-resolveAcnt :: TxRecord -> SplitAcnt -> InsertExcept T.Text
+resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text
-resolveAcnt = resolveSplitField AcntField
+resolveAcnt = resolveEntryField AcntField
 
-resolveCurrency :: TxRecord -> SplitCur -> InsertExcept T.Text
+resolveCurrency :: TxRecord -> EntryCur -> InsertExcept T.Text
-resolveCurrency = resolveSplitField CurField
+resolveCurrency = resolveEntryField CurField
 
-resolveSplitField :: SplitIDType -> TxRecord -> SplitAcnt -> InsertExcept T.Text
+resolveEntryField :: EntryIDType -> TxRecord -> EntryAcnt -> InsertExcept T.Text
-resolveSplitField t TxRecord {trOther = o} s = case s of
+resolveEntryField t TxRecord {trOther = o} s = case s of
   ConstT p -> return p
   LookupT f -> lookup_ f o
   MapT (Field f m) -> do
@@ -366,7 +469,7 @@ resolveSplitField t TxRecord {trOther = o} s = case s of
     lookup_ (k1, k2) m
   where
     lookup_ :: (Ord k, Show k) => k -> M.Map k v -> InsertExcept v
-    lookup_ = lookupErr (SplitIDField t)
+    lookup_ = lookupErr (EntryIDField t)
 
 lookupErr :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> InsertExcept v
 lookupErr what k m = case M.lookup k m of
@@ -454,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
@@ -493,8 +596,8 @@ showError other = case other of
     [T.unwords ["Could not find field", f, "when resolving", what]]
     where
       what = case t of
-        SplitIDField st -> T.unwords ["split", idName st, "ID"]
+        EntryIDField st -> T.unwords ["entry", idName st, "ID"]
-        SplitValField -> "split value"
+        EntryValField -> "entry value"
         MatchField mt -> T.unwords [matchName mt, "match"]
         DBKey st -> T.unwords ["database", idName st, "ID key"]
       -- TODO this should be its own function
@@ -526,15 +629,15 @@ showError other = case other of
         [ msg
         , "for currency"
         , singleQuote cur
-        , "and for splits"
+        , "and for entries"
-        , splits
+        , entries
         ]
     ]
     where
       msg = case t of
-        TooFewSplits -> "Need at least two splits to balance"
+        TooFewEntries -> "Need at least two entries to balance"
-        NotOneBlank -> "Exactly one split must be blank"
+        NotOneBlank -> "Exactly one entries must be blank"
-      splits = T.intercalate ", " $ fmap (singleQuote . showSplit) rss
+      entries = T.intercalate ", " $ fmap (singleQuote . showEntry) rss
 
 showGregorian_ :: Gregorian -> T.Text
 showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ showT <$> [gYear, gMonth, gDay]
@@ -622,8 +725,8 @@ showMatchOther (Val (Field f mv)) =
     , singleQuote $ fromMaybe "*" $ showValMatcher mv
     ]
 
-showSplit :: RawSplit -> T.Text
+showEntry :: RawEntry -> T.Text
-showSplit Entry {eAcnt, eValue, eComment} =
+showEntry Entry {eAcnt, eValue, eComment} =
   keyVals
     [ ("account", eAcnt)
     , ("value", T.pack $ show ((fromRational <$> eValue) :: Maybe Float))
@@ -791,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)
+  => EntryIDType
+  -> (DBState -> M.Map T.Text a)
+  -> T.Text
+  -> m a
+lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f