pwncash/lib/Internal/Insert.hs

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

askDays
  :: (MonadFinance m, MonadInsertError m)
  => DatePat
  -> Maybe Interval
  -> m [Day]
askDays dp i = do
  globalBounds <- askDBState kmBudgetInterval
  case i of
    Just i' -> do
      localBounds <- liftExcept $ resolveBounds i'
      let bounds = intersectBounds globalBounds localBounds
      maybe (return []) expand bounds
    Nothing -> expand globalBounds
  where
    expand bs = liftExcept $ expandDatePat bs dp

withDates
  :: (MonadSqlQuery m, MonadFinance m, MonadInsertError m)
  => DatePat
  -> (Day -> m a)
  -> m [a]
withDates dp f = do
  bounds <- askDBState kmBudgetInterval
  days <- liftExcept $ expandDatePat bounds dp
  combineErrors $ fmap f days

foldDays
  :: MonadInsertError m
  => (Day -> Day -> m a)
  -> Day
  -> [Day]
  -> m [a]
foldDays f start days =
  combineErrors $
    snd $
      L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days

--------------------------------------------------------------------------------
-- budget

-- each budget (designated at the top level by a 'name') is processed in the
-- following steps
-- 1. expand all transactions given the desired date range and date patterns for
--    each directive in the budget
-- 2. sort all transactions by date
-- 3. propagate all balances forward, and while doing so assign values to each
--    transaction (some of which depend on the 'current' balance of the
--    target account)
-- 4. assign shadow transactions (TODO)
-- 5. insert all transactions

insertBudget
  :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
  => Budget
  -> m ()
insertBudget
  b@Budget
    { bgtLabel
    , bgtIncomes
    , bgtTransfers
    , bgtShadowTransfers
    , bgtPretax
    , bgtTax
    , bgtPosttax
    , bgtInterval
    } =
    whenHash CTBudget b () $ \key -> do
      intAllos <- combineError3 pre_ tax_ post_ (,,)
      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
      pre_ = sortAllos bgtPretax
      tax_ = sortAllos bgtTax
      post_ = sortAllos bgtPosttax
      sortAllos = liftExcept . combineErrors . fmap sortAllo

type BoundAllocation = Allocation Bounds

type IntAllocations =
  ( [BoundAllocation PretaxValue]
  , [BoundAllocation TaxValue]
  , [BoundAllocation PosttaxValue]
  )

-- TODO this should actually error if there is no ultimate end date?
sortAllo :: MultiAllocation v -> InsertExcept (BoundAllocation v)
sortAllo a@Allocation {alloAmts = as} = do
  bs <- foldBounds [] $ L.sortOn amtWhen as
  return $ a {alloAmts = reverse bs}
  where
    foldBounds acc [] = return acc
    foldBounds acc (x : xs) = do
      let start = amtWhen x
      res <- case xs of
        [] -> resolveBounds start
        (y : _) -> resolveBounds_ (intStart $ amtWhen y) start
      foldBounds (x {amtWhen = res} : acc) xs

-- TODO this is going to be O(n*m), which might be a problem?
addShadowTransfers
  :: CurrencyMap
  -> [ShadowTransfer]
  -> [UnbalancedTransfer]
  -> InsertExcept [UnbalancedTransfer]
addShadowTransfers cm ms txs =
  fmap catMaybes $
    combineErrors $
      fmap (uncurry (fromShadow cm)) $
        [(t, m) | t <- txs, m <- ms]

fromShadow
  :: CurrencyMap
  -> UnbalancedTransfer
  -> ShadowTransfer
  -> InsertExcept (Maybe UnbalancedTransfer)
fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do
  res <- shadowMatches (stMatch t) tx
  v <- roundPrecisionCur (initialCurrency stCurrency) cm stRatio
  return $
    if not res
      then Nothing
      else
        Just $
          -- TODO does this actually share the same metadata as the "parent" tx?
          FlatTransfer
            { ftMeta = ftMeta tx
            , ftWhen = ftWhen tx
            , ftCur = stCurrency
            , ftFrom = stFrom
            , ftTo = stTo
            , ftValue = UnbalancedValue stType $ v * cvValue (ftValue tx)
            , ftDesc = stDesc
            }

shadowMatches :: TransferMatcher -> UnbalancedTransfer -> InsertExcept Bool
shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do
  valRes <- valMatches tmVal $ cvValue $ ftValue tx
  return $
    memberMaybe (taAcnt $ ftFrom tx) tmFrom
      && memberMaybe (taAcnt $ ftTo tx) tmTo
      && maybe True (`dateMatches` ftWhen tx) tmDate
      && valRes
  where
    memberMaybe x AcntSet {asList, asInclude} =
      (if asInclude then id else not) $ x `elem` asList

balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer]
balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen
  where
    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

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
  { ftFrom :: !TaggedAcnt
  , ftTo :: !TaggedAcnt
  , ftValue :: !v
  , ftWhen :: !Day
  , ftDesc :: !T.Text
  , ftMeta :: !BudgetMeta
  , ftCur :: !BudgetCurrency
  }
  deriving (Show)

data UnbalancedValue = UnbalancedValue
  { cvType :: !BudgetTransferType
  , cvValue :: !Rational
  }
  deriving (Show)

type UnbalancedTransfer = FlatTransfer UnbalancedValue

type BalancedTransfer = FlatTransfer Rational

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
    } = 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 :(
    days <- askDays incWhen localInterval
    res <- foldDays (allocate precision gross) start days
    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
                { 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))

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
    { ftMeta = meta
    , ftWhen = day
    , ftFrom = from
    , ftCur = faCur
    , ftTo = faTo
    , ftValue = UnbalancedValue BTFixed faValue
    , ftDesc = 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
  -> 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 $ resolveBounds i
      return $ filter (inBounds bounds . ftWhen) txs

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
              { ftMeta = meta
              , ftWhen = day
              , ftCur = transCurrency
              , ftFrom = transFrom
              , ftTo = transTo
              , ftValue = UnbalancedValue y $ roundPrecision precision v
              , ftDesc = desc
              }

insertBudgetTx :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) => BalancedTransfer -> m ()
insertBudgetTx FlatTransfer {ftFrom, ftTo, ftMeta, ftCur, ftValue, ftDesc, ftWhen} = do
  ((sFrom, sTo), exchange) <- splitPair ftFrom ftTo ftCur ftValue
  insertPair sFrom sTo
  forM_ exchange $ uncurry insertPair
  where
    insertPair from to = do
      k <- insert $ TransactionR (bmCommit ftMeta) ftWhen ftDesc
      insertBudgetLabel k from
      insertBudgetLabel k to
    insertBudgetLabel k split = do
      sk <- insertSplit k split
      insert_ $ BudgetLabelR sk $ bmName ftMeta

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 <- 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