pwncash/lib/Internal/Utils.hs

module Internal.Utils
  ( compareDate
  , expandDatePat
  , askDays
  , fromWeekday
  , inDaySpan
  , fmtRational
  , matches
  , fromGregorian'
  , resolveDaySpan
  , resolveDaySpan_
  , intersectDaySpan
  , liftInner
  , liftExceptT
  , liftExcept
  , liftIOExcept
  , liftIOExceptT
  , combineError
  , combineError_
  , combineError3
  , combineErrors
  , mapErrors
  , combineErrorM
  , combineErrorM3
  , combineErrorIO2
  , combineErrorIO3
  , combineErrorIOM2
  , combineErrorIOM3
  , collectErrorsIO
  , mapErrorsIO
  , parseRational
  , showError
  , unlessLeft_
  , unlessLefts_
  , unlessLeft
  , unlessLefts
  , acntPath2Text
  , showT
  , lookupErr
  , gregorians
  , uncurry3
  , fstOf3
  , sndOf3
  , thdOf3
  , xGregToDay
  , compileMatch
  , compileOptions
  , dateMatches
  , valMatches
  , roundPrecision
  , roundPrecisionCur
  , lookupAccount
  , lookupAccountKey
  , lookupAccountSign
  , lookupAccountType
  , lookupCurrency
  , lookupCurrencyKey
  , lookupCurrencyPrec
  , lookupTag
  , mapAdd_
  , groupKey
  , groupWith
  , balanceTxs
  , expandTransfers
  , expandTransfer
  , entryPair
  )
where

import Control.Monad.Error.Class
import Control.Monad.Except
import Data.Time.Format.ISO8601
import GHC.Real
import Internal.Types.Main
import RIO
import qualified RIO.List as L
import qualified RIO.Map as M
import qualified RIO.NonEmpty as NE
import RIO.State
import qualified RIO.Text as T
import RIO.Time
import qualified RIO.Vector as V
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

-- | Lame weekday converter since day of weeks aren't in dhall (yet)
fromWeekday :: Weekday -> DayOfWeek
fromWeekday Mon = Monday
fromWeekday Tue = Tuesday
fromWeekday Wed = Wednesday
fromWeekday Thu = Thursday
fromWeekday Fri = Friday
fromWeekday Sat = Saturday
fromWeekday Sun = Sunday

-- | find the next date
-- this is meant to go in a very tight loop and be very fast (hence no
-- complex date functions, most of which heavily use 'mod' and friends)
nextXGreg :: XGregorian -> XGregorian
nextXGreg XGregorian {xgYear = y, xgMonth = m, xgDay = d, xgDayOfWeek = w}
  | m == 12 && d == 31 = XGregorian (y + 1) 1 1 w_
  | (m == 2 && (not leap && d == 28 || (leap && d == 29)))
      || (m `elem` [4, 6, 9, 11] && d == 30)
      || (d == 31) =
      XGregorian y (m + 1) 1 w_
  | otherwise = XGregorian y m (d + 1) w_
  where
    -- don't use DayOfWeek from Data.Time since this uses mod (which uses a
    -- division opcode) and thus will be slower than just checking for equality
    -- and adding
    w_ = if w == 6 then 0 else w + 1
    leap = isLeapYear $ fromIntegral y

gregorians :: Day -> [XGregorian]
gregorians x = L.iterate nextXGreg $ XGregorian (fromIntegral y) m d w
  where
    (y, m, d) = toGregorian x
    w = fromEnum $ dayOfWeek x

xGregToDay :: XGregorian -> Day
xGregToDay XGregorian {xgYear = y, xgMonth = m, xgDay = d} = fromGregorian (fromIntegral y) m d

gregTup :: Gregorian -> (Integer, Int, Int)
gregTup Gregorian {gYear, gMonth, gDay} =
  ( fromIntegral gYear
  , fromIntegral gMonth
  , fromIntegral gDay
  )

gregMTup :: GregorianM -> (Integer, Int)
gregMTup GregorianM {gmYear, gmMonth} =
  ( fromIntegral gmYear
  , fromIntegral gmMonth
  )

data YMD_ = Y_ !Integer | YM_ !Integer !Int | YMD_ !Integer !Int !Int

fromYMDMatcher :: YMDMatcher -> YMD_
fromYMDMatcher m = case m of
  Y y -> Y_ $ fromIntegral y
  YM g -> uncurry YM_ $ gregMTup g
  YMD g -> uncurry3 YMD_ $ gregTup g

compareDate :: DateMatcher -> Day -> Ordering
compareDate (On md) x =
  case fromYMDMatcher md of
    Y_ y' -> compare y y'
    YM_ y' m' -> compare (y, m) (y', m')
    YMD_ y' m' d' -> compare (y, m, d) (y', m', d')
  where
    (y, m, d) = toGregorian x
compareDate (In md offset) x = do
  case fromYMDMatcher md of
    Y_ y' -> compareRange y' y
    YM_ y' m' -> compareRange (toMonth y' m') $ toMonth y m
    YMD_ y' m' d' ->
      let s = toModifiedJulianDay $ fromGregorian y' m' d'
       in compareRange s $ toModifiedJulianDay x
  where
    (y, m, _) = toGregorian x
    compareRange start z
      | z < start = LT
      | otherwise = if (start + fromIntegral offset - 1) < z then GT else EQ
    toMonth year month = (year * 12) + fromIntegral month

fromGregorian' :: Gregorian -> Day
fromGregorian' = uncurry3 fromGregorian . gregTup

inDaySpan :: DaySpan -> Day -> Bool
inDaySpan bs = withinDays (fromDaySpan bs)

withinDays :: (Day, Day) -> Day -> Bool
withinDays (d0, d1) x = d0 <= x && x < d1

resolveDaySpan :: Interval -> InsertExcept DaySpan
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} =
  -- TODO the default isn't checked here :/
  case fromGregorian' <$> e of
    Nothing -> return $ toDaySpan_ $ fromGregorian' def
    Just e_
      | s_ < e_ -> return $ toDaySpan_ e_
      | otherwise -> throwError $ InsertException [DaySpanError s e]
  where
    s_ = fromGregorian' s
    toDaySpan_ end = toDaySpan (s_, end)

fromDaySpan :: DaySpan -> (Day, Day)
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

matches :: MonadFinance m => MatchRe -> TxRecord -> InsertExceptT m (MatchRes (Tx ()))
matches
  StatementParser {spTx, spOther, spVal, spDate, spDesc}
  r@TxRecord {trDate, trAmount, trDesc, trOther} = do
    res <- liftInner $
      combineError3 val other desc $
        \x y z -> x && y && z && date
    if res
      then maybe (return MatchSkip) convert spTx
      else return MatchFail
    where
      val = valMatches spVal trAmount
      date = maybe True (`dateMatches` trDate) spDate
      other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True spOther
      desc = maybe (return True) (matchMaybe trDesc . snd) spDesc
      convert tg = MatchPass <$> toTx tg r

toTx :: MonadFinance m => TxGetter -> TxRecord -> InsertExceptT m (Tx ())
toTx
  TxGetter
    { tgFrom
    , tgTo
    , tgCurrency
    , tgOtherEntries
    , tgScale
    }
  r@TxRecord {trAmount, trDate, trDesc} = do
    combineError curRes subRes $ \(cur, f, t) ss ->
      Tx
        { txDate = trDate
        , txDescr = trDesc
        , txCommit = ()
        , txPrimary =
            Left $
              EntrySet
                { esTotalValue = roundPrecisionCur cur $ tgScale * fromRational trAmount
                , esCurrency = cur
                , esFrom = f
                , esTo = t
                }
        , txOther = fmap Left ss
        }
    where
      curRes = do
        m <- askDBState kmCurrency
        cur <- liftInner $ resolveCurrency m r tgCurrency
        let fromRes = liftInner $ resolveHalfEntry resolveFromValue cur r () tgFrom
        let toRes = liftInner $ resolveHalfEntry resolveToValue cur r () tgTo
        combineError fromRes toRes (cur,,)
      subRes = mapErrors (resolveSubGetter r) tgOtherEntries

resolveSubGetter
  :: MonadFinance m
  => TxRecord
  -> TxSubGetter
  -> InsertExceptT m SecondayEntrySet
resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
  m <- askDBState kmCurrency
  cur <- liftInner $ resolveCurrency m r tsgCurrency
  let toRes = resolveHalfEntry resolveToValue cur r () tsgTo
  let valRes = liftInner $ fmap (roundPrecisionCur cur) <$> resolveValue r tsgValue
  liftInner $ combineErrorM toRes valRes $ \t v -> do
    f <- resolveHalfEntry resolveFromValue cur r v tsgFrom
    return $
      EntrySet
        { esTotalValue = ()
        , esCurrency = cur
        , esFrom = f
        , esTo = t
        }

resolveHalfEntry
  :: Traversable f
  => (TxRecord -> n -> InsertExcept (f Double))
  -> CurrencyPrec
  -> TxRecord
  -> v
  -> TxHalfGetter (EntryGetter n)
  -> InsertExcept (HalfEntrySet v (f Rational))
resolveHalfEntry f cur r v TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} =
  combineError acntRes esRes $ \a es ->
    HalfEntrySet
      { hesPrimary =
          Entry
            { eAcnt = a
            , eValue = v
            , eComment = thgComment
            , eTags = thgTags
            }
      , hesOther = es
      }
  where
    acntRes = resolveAcnt r thgAcnt
    esRes = mapErrors (resolveEntry f cur r) thgEntries

valMatches :: ValMatcher -> Rational -> InsertExcept Bool
valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
  | Just d_ <- vmDen, d_ >= p = throwError $ InsertException [MatchValPrecisionError d_ p]
  | otherwise =
      return $
        checkMaybe (s ==) vmSign
          && checkMaybe (n ==) vmNum
          && checkMaybe ((d * fromIntegral p ==) . fromIntegral) vmDen
  where
    (n, d) = properFraction $ abs x
    p = 10 ^ vmPrec
    s = signum x >= 0
    checkMaybe = maybe True

dateMatches :: DateMatcher -> Day -> Bool
dateMatches md = (EQ ==) . compareDate md

otherMatches :: M.Map T.Text T.Text -> FieldMatcherRe -> InsertExcept Bool
otherMatches dict m = case m of
  Val (Field n mv) -> valMatches mv =<< (readRational =<< lookup_ MatchNumeric n)
  Desc (Field n (_, md)) -> (`matchMaybe` md) =<< lookup_ MatchText n
  where
    lookup_ t n = lookupErr (MatchField t) n dict

resolveEntry
  :: Traversable f
  => (TxRecord -> n -> InsertExcept (f Double))
  -> CurrencyPrec
  -> TxRecord
  -> EntryGetter n
  -> InsertExcept (Entry AcntID (f Rational) TagID)
resolveEntry f cur r s@Entry {eAcnt, eValue} = do
  combineError acntRes valRes $ \a v ->
    s {eAcnt = a, eValue = roundPrecisionCur cur <$> v}
  where
    acntRes = resolveAcnt r eAcnt
    valRes = f r eValue

liftInner :: Monad m => ExceptT e Identity a -> ExceptT e m a
liftInner = mapExceptT (return . runIdentity)

liftExceptT :: MonadError e m => ExceptT e m a -> m a
liftExceptT x = runExceptT x >>= either throwError return

liftExcept :: MonadError e m => Except e a -> m a
liftExcept = either throwError return . runExcept

-- tryError :: MonadError e m => m a -> m (Either e a)
-- tryError action = (Right <$> action) `catchError` (pure . Left)

liftIOExceptT :: MonadIO m => InsertExceptT m a -> m a
liftIOExceptT = fromEither <=< runExceptT

liftIOExcept :: MonadIO m => InsertExcept a -> m a
liftIOExcept = fromEither . runExcept

combineError :: MonadError InsertException m => m a -> m b -> (a -> b -> c) -> m c
combineError a b f = combineErrorM a b (\x y -> pure $ f x y)

combineError_ :: MonadError InsertException m => m a -> m b -> m ()
combineError_ a b = do
  _ <- catchError a $ \e ->
    throwError =<< catchError (e <$ b) (return . (e <>))
  _ <- b
  return ()

combineErrorM :: MonadError InsertException m => m a -> m b -> (a -> b -> m c) -> m c
combineErrorM a b f = do
  a' <- catchError a $ \e ->
    throwError =<< catchError (e <$ b) (return . (e <>))
  f a' =<< b

combineError3 :: MonadError InsertException m => m a -> m b -> m c -> (a -> b -> c -> d) -> m d
combineError3 a b c f =
  combineError (combineError a b (,)) c $ \(x, y) z -> f x y z

combineErrorM3 :: MonadError InsertException m => m a -> m b -> m c -> (a -> b -> c -> m d) -> m d
combineErrorM3 a b c f = do
  combineErrorM (combineErrorM a b (curry return)) c $ \(x, y) z -> f x y z

mapErrors
  :: (Traversable t, MonadError InsertException m)
  => (a -> m b)
  -> t a
  -> m (t b)
-- First, record number of each action. Then try each action. On first failure,
-- note it's position in the sequence, skip ahead to the untried actions,
-- collect failures and add to the first failure.
mapErrors f xs = mapM go $ enumTraversable xs
  where
    go (n, x) = catchError (f x) $ \e -> do
      es <- fmap catMaybes $ mapM (err . f) $ drop (n + 1) $ toList xs
      throwError $ foldr (<>) e es
    err x = catchError (Nothing <$ x) (pure . Just)

combineErrors :: (Traversable t, MonadError InsertException m) => t (m a) -> m (t a)
combineErrors = mapErrors id

enumTraversable :: (Num n, Traversable t) => t a -> t (n, a)
enumTraversable = snd . L.mapAccumL go 0
  where
    go n x = (n + 1, (n, x))

combineErrorIO2 :: MonadUnliftIO m => m a -> m b -> (a -> b -> c) -> m c
combineErrorIO2 a b f = combineErrorIOM2 a b (\x y -> pure $ f x y)

combineErrorIO3 :: MonadUnliftIO m => m a -> m b -> m c -> (a -> b -> c -> d) -> m d
combineErrorIO3 a b c f = combineErrorIOM3 a b c (\x y z -> pure $ f x y z)

combineErrorIOM2 :: MonadUnliftIO m => m a -> m b -> (a -> b -> m c) -> m c
combineErrorIOM2 a b f = do
  a' <- catch a $ \(InsertException es) ->
    (throwIO . InsertException)
      =<< catch (es <$ b) (\(InsertException es') -> return (es' ++ es))
  f a' =<< b

combineErrorIOM3 :: MonadUnliftIO m => m a -> m b -> m c -> (a -> b -> c -> m d) -> m d
combineErrorIOM3 a b c f =
  combineErrorIOM2 (combineErrorIOM2 a b (curry return)) c $ \(x, y) z -> f x y z

mapErrorsIO :: (Traversable t, MonadUnliftIO m) => (a -> m b) -> t a -> m (t b)
mapErrorsIO f xs = mapM go $ enumTraversable xs
  where
    go (n, x) = catch (f x) $ \(InsertException e) -> do
      es <- fmap catMaybes $ mapM (err . f) $ drop (n + 1) $ toList xs
      throwIO $ InsertException $ foldr (<>) e es
    err x = catch (Nothing <$ x) $ \(InsertException es) -> pure $ Just es

collectErrorsIO :: (Traversable t, MonadUnliftIO m) => t (m a) -> m (t a)
collectErrorsIO = mapErrorsIO id

resolveFromValue :: TxRecord -> EntryNumGetter -> InsertExcept (EntryValue Double)
resolveFromValue = resolveValue

resolveToValue :: TxRecord -> LinkedEntryNumGetter -> InsertExcept (LinkDeferred Double)
resolveToValue _ (Linked l) = return $ LinkIndex l
resolveToValue r (Getter g) = LinkDeferred <$> resolveValue r g

resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept (EntryValue Double)
resolveValue TxRecord {trOther, trAmount} s = case s of
  (LookupN t) -> EntryValue TFixed <$> (readDouble =<< lookupErr EntryValField t trOther)
  (ConstN c) -> return $ EntryValue TFixed c
  AmountN m -> return $ EntryValue TFixed $ m * fromRational trAmount
  BalanceN x -> return $ EntryValue TBalance x
  PercentN x -> return $ EntryValue TPercent x

resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text
resolveAcnt = resolveEntryField AcntField

resolveCurrency :: CurrencyMap -> TxRecord -> EntryCur -> InsertExcept CurrencyPrec
resolveCurrency m r c = do
  i <- resolveEntryField CurField r c
  case M.lookup i m of
    Just k -> return k
    -- TODO this should be its own error (I think)
    Nothing -> throwError $ InsertException [LookupError (EntryIDField CurField) undefined]

resolveEntryField :: EntryIDType -> TxRecord -> EntryAcnt -> InsertExcept T.Text
resolveEntryField t TxRecord {trOther = o} s = case s of
  ConstT p -> return p
  LookupT f -> lookup_ f o
  MapT (Field f m) -> do
    k <- lookup_ f o
    lookup_ k m
  Map2T (Field (f1, f2) m) -> do
    (k1, k2) <- combineError (lookup_ f1 o) (lookup_ f2 o) (,)
    lookup_ (k1, k2) m
  where
    lookup_ :: (Ord k, Show k) => k -> M.Map k v -> InsertExcept v
    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
  Just x -> return x
  _ -> throwError $ InsertException [LookupError what $ showT k]

parseRational :: MonadFail m => (T.Text, Regex) -> T.Text -> m Rational
parseRational (pat, re) s = case matchGroupsMaybe s re of
  [sign, x, ""] -> uncurry (*) <$> readWhole sign x
  [sign, x, y] -> do
    d <- readT "decimal" y
    let p = 10 ^ T.length y
    (k, w) <- readWhole sign x
    return $ k * (w + d % p)
  _ -> msg "malformed decimal"
  where
    readT what t = case readMaybe $ T.unpack t of
      Just d -> return $ fromInteger d
      _ -> msg $ T.unwords ["could not parse", what, singleQuote t]
    msg :: MonadFail m => T.Text -> m a
    msg m =
      fail $
        T.unpack $
          T.unwords [m, "-", keyVals [("pattern", pat), ("query", s)]]
    readSign x
      | x == "-" = return (-1)
      | x == "+" || x == "" = return 1
      | otherwise = msg $ T.append "invalid sign: " x
    readWhole sign x = do
      w <- readT "whole number" x
      k <- readSign sign
      return (k, w)

readDouble :: T.Text -> InsertExcept Double
readDouble s = case readMaybe $ T.unpack s of
  Just x -> return x
  Nothing -> throwError $ InsertException [ConversionError s]

readRational :: T.Text -> InsertExcept Rational
readRational s = case T.split (== '.') s of
  [x] -> maybe err (return . fromInteger) $ readT x
  [x, y] -> case (readT x, readT y) of
    (Just x', Just y') ->
      let p = 10 ^ T.length y
          k = if x' >= 0 then 1 else -1
       in return $ fromInteger x' + k * y' % p
    _ -> err
  _ -> err
  where
    readT = readMaybe . T.unpack
    err = throwError $ InsertException [ConversionError s]

-- TODO smells like a lens
-- mapTxSplits :: (a -> b) -> Tx a -> Tx b
-- mapTxSplits f t@Tx {txSplits = ss} = t {txSplits = fmap f ss}

fmtRational :: Natural -> Rational -> T.Text
fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d']
  where
    s = if x >= 0 then "" else "-"
    x'@(n :% d) = abs x
    p = 10 ^ precision
    n' = div n d
    d' = (\(a :% b) -> div a b) ((x' - fromIntegral n') * p)
    txt = T.pack . show
    pad i c z = T.append (T.replicate (i - T.length z) c) z

roundPrecision :: Natural -> Double -> Rational
roundPrecision n = (% p) . round . (* fromIntegral p) . toRational
  where
    p = 10 ^ n

roundPrecisionCur :: CurrencyPrec -> Double -> Rational
roundPrecisionCur (CurrencyPrec _ n) = roundPrecision n

acntPath2Text :: AcntPath -> T.Text
acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)

--------------------------------------------------------------------------------
-- error display

showError :: InsertError -> [T.Text]
showError other = case other of
  (StatementError ts ms) -> (showTx <$> ts) ++ (showMatch <$> ms)
  (DaySpanError a b) ->
    [T.unwords ["Could not create bounds from", showGregorian_ a, "and", showGreg b]]
    where
      showGreg (Just g) = showGregorian_ g
      showGreg Nothing = "Inf"
  (AccountError a ts) ->
    [ T.unwords
        [ "account type of key"
        , singleQuote a
        , "is not one of:"
        , ts_
        ]
    ]
    where
      ts_ = T.intercalate ", " $ NE.toList $ fmap atName ts
  (PatternError s b r p) -> [T.unwords [msg, "in pattern: ", pat]]
    where
      pat =
        keyVals $
          [ (k, v)
          | (k, Just v) <-
              [ ("start", Just $ showT s)
              , ("by", Just $ showT b)
              , ("repeats", showT <$> r)
              ]
          ]
      msg = case p of
        ZeroLength -> "Zero repeat length"
        ZeroRepeats -> "Zero repeats"
  (RegexError re) -> [T.append "could not make regex from pattern: " re]
  (ConversionError x) -> [T.append "Could not convert to rational number: " x]
  (InsertIOError msg) -> [T.append "IO Error: " msg]
  (ParseError msg) -> [T.append "Parse Error: " msg]
  (MatchValPrecisionError d p) ->
    [T.unwords ["Match denominator", showT d, "must be less than", showT p]]
  (LookupError t f) ->
    [T.unwords ["Could not find field", f, "when resolving", what]]
    where
      what = case t of
        EntryIDField st -> T.unwords ["entry", idName st, "ID"]
        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
      idName AcntField = "account"
      idName CurField = "currency"
      idName TagField = "tag"
      matchName MatchNumeric = "numeric"
      matchName MatchText = "text"
  (IncomeError day name balance) ->
    [ T.unwords
        [ "Income allocations for budget"
        , singleQuote name
        , "exceed total on day"
        , showT day
        , "where balance is"
        , showT (fromRational balance :: Double)
        ]
    ]
  (PeriodError start next) ->
    [ T.unwords
        [ "First pay period on "
        , singleQuote $ showT start
        , "must start before first income payment on "
        , singleQuote $ showT next
        ]
    ]
  (IndexError Entry {eValue = LinkedNumGetter {lngIndex}, eAcnt} day) ->
    [ T.unwords
        [ "No credit entry for index"
        , singleQuote $ showT lngIndex
        , "for entry with account"
        , singleQuote eAcnt
        , "on"
        , showT day
        ]
    ]
  (RoundError cur) ->
    [ T.unwords
        [ "Could not look up precision for currency"
        , singleQuote cur
        ]
    ]

showGregorian_ :: Gregorian -> T.Text
showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ showT <$> [gYear, gMonth, gDay]

showTx :: TxRecord -> T.Text
showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} =
  T.append "Unmatched transaction: " $
    keyVals
      [ ("path", T.pack f)
      , ("date", T.pack $ iso8601Show d)
      , ("value", showT (fromRational v :: Float))
      , ("description", doubleQuote e)
      ]

showMatch :: MatchRe -> T.Text
showMatch StatementParser {spDate, spVal, spDesc, spOther, spTimes, spPriority} =
  T.append "Unused match: " $ keyVals [(x, y) | (x, Just y) <- kvs]
  where
    kvs =
      [ ("date", showDateMatcher <$> spDate)
      , ("val", showValMatcher spVal)
      , ("desc", fst <$> spDesc)
      , ("other", others)
      , ("counter", Just $ maybe "Inf" showT spTimes)
      , ("priority", Just $ showT spPriority)
      ]
    others = case spOther of
      [] -> Nothing
      xs -> Just $ singleQuote $ T.concat $ showMatchOther <$> xs

-- | Convert match date to text
-- Single date matches will just show the single date, and ranged matches will
-- show an interval like [YY-MM-DD, YY-MM-DD)
showDateMatcher :: DateMatcher -> T.Text
showDateMatcher md = case md of
  (On x) -> showYMDMatcher x
  (In start n) -> T.concat ["[", showYMDMatcher start, " ", showYMD_ end, ")"]
    where
      -- TODO not DRY (this shifting thing happens during the comparison
      -- function (kinda)
      end = case fromYMDMatcher start of
        Y_ y -> Y_ $ y + fromIntegral n
        YM_ y m ->
          let (y_, m_) = divMod (m + fromIntegral n - 1) 12
           in YM_ (y + fromIntegral y_) (m + m_ + 1)
        YMD_ y m d ->
          uncurry3 YMD_ $
            toGregorian $
              addDays (fromIntegral n) $
                fromGregorian y m d

-- | convert YMD match to text
showYMDMatcher :: YMDMatcher -> T.Text
showYMDMatcher = showYMD_ . fromYMDMatcher

showYMD_ :: YMD_ -> T.Text
showYMD_ md =
  T.intercalate "-" $ L.take 3 (fmap showT digits ++ L.repeat "*")
  where
    digits = case md of
      Y_ y -> [fromIntegral y]
      YM_ y m -> [fromIntegral y, m]
      YMD_ y m d -> [fromIntegral y, m, d]

showValMatcher :: ValMatcher -> Maybe T.Text
showValMatcher ValMatcher {vmSign = Nothing, vmNum = Nothing, vmDen = Nothing} = Nothing
showValMatcher ValMatcher {vmNum, vmDen, vmSign, vmPrec} =
  Just $ singleQuote $ keyVals [(k, v) | (k, Just v) <- kvs]
  where
    kvs =
      [ ("sign", (\s -> if s then "+" else "-") <$> vmSign)
      , ("numerator", showT <$> vmNum)
      , ("denominator", showT <$> vmDen)
      , ("precision", Just $ showT vmPrec)
      ]

showMatchOther :: FieldMatcherRe -> T.Text
showMatchOther (Desc (Field f (re, _))) =
  T.unwords ["desc field", singleQuote f, "with re", singleQuote re]
showMatchOther (Val (Field f mv)) =
  T.unwords
    [ "val field"
    , singleQuote f
    , "with match value"
    , singleQuote $ fromMaybe "*" $ showValMatcher mv
    ]

singleQuote :: T.Text -> T.Text
singleQuote t = T.concat ["'", t, "'"]

doubleQuote :: T.Text -> T.Text
doubleQuote t = T.concat ["'", t, "'"]

keyVal :: T.Text -> T.Text -> T.Text
keyVal a b = T.concat [a, "=", b]

keyVals :: [(T.Text, T.Text)] -> T.Text
keyVals = T.intercalate "; " . fmap (uncurry keyVal)

showT :: Show a => a -> T.Text
showT = T.pack . show

--------------------------------------------------------------------------------
-- pure error processing

-- concatEither2 :: Either x a -> Either x b -> (a -> b -> c) -> Either [x] c
-- concatEither2 a b fun = case (a, b) of
--   (Right a_, Right b_) -> Right $ fun a_ b_
--   _ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b]

-- concatEither2M :: Monad m => Either x a -> Either x b -> (a -> b -> m c) -> m (Either [x] c)
-- concatEither2M a b fun = case (a, b) of
--   (Right a_, Right b_) -> Right <$> fun a_ b_
--   _ -> return $ Left $ catMaybes [leftToMaybe a, leftToMaybe b]

-- concatEither3 :: Either x a -> Either x b -> Either x c -> (a -> b -> c -> d) -> Either [x] d
-- concatEither3 a b c fun = case (a, b, c) of
--   (Right a_, Right b_, Right c_) -> Right $ fun a_ b_ c_
--   _ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b, leftToMaybe c]

-- concatEithers2 :: Either [x] a -> Either [x] b -> (a -> b -> c) -> Either [x] c
-- concatEithers2 a b = merge . concatEither2 a b

-- concatEithers2M
--   :: Monad m
--   => Either [x] a
--   -> Either [x] b
--   -> (a -> b -> m c)
--   -> m (Either [x] c)
-- concatEithers2M a b = fmap merge . concatEither2M a b

-- concatEithers3
--   :: Either [x] a
--   -> Either [x] b
--   -> Either [x] c
--   -> (a -> b -> c -> d)
--   -> Either [x] d
-- concatEithers3 a b c = merge . concatEither3 a b c

-- concatEitherL :: [Either x a] -> Either [x] [a]
-- concatEitherL as = case partitionEithers as of
--   ([], bs) -> Right bs
--   (es, _) -> Left es

-- concatEithersL :: [Either [x] a] -> Either [x] [a]
-- concatEithersL = merge . concatEitherL

-- leftToMaybe :: Either a b -> Maybe a
-- leftToMaybe (Left a) = Just a
-- leftToMaybe _ = Nothing

unlessLeft :: (Monad m, MonadPlus n) => Either a b -> (b -> m (n a)) -> m (n a)
unlessLeft (Left es) _ = return (return es)
unlessLeft (Right rs) f = f rs

unlessLefts :: (Monad m) => Either (n a) b -> (b -> m (n a)) -> m (n a)
unlessLefts (Left es) _ = return es
unlessLefts (Right rs) f = f rs

unlessLeft_ :: (Monad m, MonadPlus n) => Either a b -> (b -> m ()) -> m (n a)
unlessLeft_ e f = unlessLeft e (\x -> void (f x) >> return mzero)

unlessLefts_ :: (Monad m, MonadPlus n) => Either (n a) b -> (b -> m ()) -> m (n a)
unlessLefts_ e f = unlessLefts e (\x -> void (f x) >> return mzero)

-- plural :: Either a b -> Either [a] b
-- plural = first (: [])

-- merge :: Either [[a]] b -> Either [a] b
-- merge = first concat

--------------------------------------------------------------------------------
-- random functions

-- when bifunctor fails...
-- thrice :: (a -> d) -> (b -> e) -> (c -> f) -> (a, b, c) -> (d, e, f)
-- thrice f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)

-- groupKey :: Ord c => (a -> c) -> [(a, b)] -> [(a, [b])]
-- groupKey f = fmap go . NE.groupAllWith (f . fst)
--   where
--     go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)

groupKey :: Ord c => (a -> c) -> [(a, b)] -> [(a, NonEmpty b)]
groupKey f = fmap go . NE.groupAllWith (f . fst)
  where
    go xs@((c, _) :| _) = (c, fmap snd xs)

groupWith :: Ord b => (a -> b) -> [a] -> [(b, [a])]
groupWith f = fmap go . NE.groupAllWith fst . fmap (\x -> (f x, x))
  where
    go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)

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

uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 f (a, b, c) = f a b c

fstOf3 :: (a, b, c) -> a
fstOf3 (a, _, _) = a

sndOf3 :: (a, b, c) -> b
sndOf3 (_, b, _) = b

thdOf3 :: (a, b, c) -> c
thdOf3 (_, _, c) = c

-- lpad :: a -> Int -> [a] -> [a]
-- lpad c n s = replicate (n - length s) c ++ s

-- rpad :: a -> Int -> [a] -> [a]
-- rpad c n s = s ++ replicate (n - length s) c

-- lpadT :: Char -> Int -> T.Text -> T.Text
-- lpadT c n s = T.append (T.replicate (n - T.length s) (T.singleton c)) s

-- TODO this regular expression appears to be compiled each time, which is
-- super slow
-- NOTE: see https://github.com/haskell-hvr/regex-tdfa/issues/9 - performance
-- is likely not going to be optimal for text
-- matchMaybe :: T.Text -> T.Text -> EitherErr Bool
-- matchMaybe q pat = case compres of
--   Right re -> case execute re q of
--     Right res -> Right $ isJust res
--     Left _ -> Left $ RegexError "this should not happen"
--   Left _ -> Left $ RegexError pat
--   where
--     -- these options barely do anything in terms of performance
--     compres = compile (blankCompOpt {newSyntax = True}) (blankExecOpt {captureGroups = False}) pat

compileOptions :: TxOpts T.Text -> InsertExcept TxOptsRe
compileOptions o@TxOpts {toAmountFmt = pat} = do
  re <- compileRegex True pat
  return $ o {toAmountFmt = re}

compileMatch :: StatementParser T.Text -> InsertExcept MatchRe
compileMatch m@StatementParser {spDesc, spOther} = do
  combineError dres ores $ \d os -> m {spDesc = d, spOther = os}
  where
    go = compileRegex False
    dres = mapM go spDesc
    ores = combineErrors $ fmap (mapM go) spOther

compileRegex :: Bool -> T.Text -> InsertExcept (Text, Regex)
compileRegex groups pat = case res of
  Right re -> return (pat, re)
  Left _ -> throwError $ InsertException [RegexError pat]
  where
    res =
      compile
        (blankCompOpt {newSyntax = True})
        (blankExecOpt {captureGroups = groups})
        pat

matchMaybe :: T.Text -> Regex -> InsertExcept Bool
matchMaybe q re = case execute re q of
  Right res -> return $ isJust res
  Left _ -> throwError $ InsertException [RegexError "this should not happen"]

matchGroupsMaybe :: T.Text -> Regex -> [T.Text]
matchGroupsMaybe q re = case regexec re q of
  Right Nothing -> []
  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) => CurID -> m CurrencyPrec
lookupCurrency = lookupFinance CurField kmCurrency

lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m CurrencyRId
lookupCurrencyKey = fmap cpID . lookupCurrency

lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => AcntID -> m Natural
lookupCurrencyPrec = fmap cpPrec . 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

balanceTxs
  :: (MonadInsertError m, MonadFinance m)
  => [EntryBin]
  -> m ([UEBalanced], [InsertTx])
balanceTxs ebs =
  first concat . partitionEithers . catMaybes
    <$> evalStateT (mapErrors go $ L.sortOn binDate ebs) M.empty
  where
    go (ToUpdate utx) =
      fmap (Just . Left) $
        liftInnerS $
          either rebalanceTotalEntrySet rebalanceFullEntrySet utx
    go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do
      modify $ mapAdd_ (reAcnt, reCurrency) reValue
      return Nothing
    go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate}) = do
      e <- either balancePrimaryEntrySet balanceSecondaryEntrySet txPrimary
      let tot = sum $ fmap (eValue . ieEntry) $ NE.toList $ iesFromEntries e
      es <- mapErrors (either balanceSecondaryEntrySet (balancePrimaryEntrySet . fromShadow tot)) txOther
      let tx =
            InsertTx
              { itxDescr = txDescr
              , itxDate = txDate
              , itxEntrySets = e :| es
              , itxCommit = txCommit
              }
      return $ Just $ Right tx
    fromShadow tot e@EntrySet {esTotalValue} = e {esTotalValue = tot * toRational esTotalValue}

binDate :: EntryBin -> Day
binDate (ToUpdate (Right UpdateEntrySet {utDate})) = utDate
binDate (ToUpdate (Left UpdateEntrySet {utDate})) = utDate
binDate (ToRead ReadEntry {reDate}) = reDate
binDate (ToInsert Tx {txDate}) = txDate

type EntryBals = M.Map (AccountRId, CurrencyRId) Rational

data UpdateEntryType a b
  = UET_ReadOnly UE_RO
  | UET_Unk a
  | UET_Linked b

-- TODO make sure new values are rounded properly here
rebalanceTotalEntrySet :: TotalUpdateEntrySet -> State EntryBals [UEBalanced]
rebalanceTotalEntrySet
  UpdateEntrySet
    { utFrom0 = (f0, f0links)
    , utTo0
    , -- , utPairs
    utFromUnk
    , utToUnk
    , utFromRO
    , utToRO
    , utCurrency
    , -- , utToUnkLink0
    utTotalValue
    } =
    do
      (f0val, (tpairs, fs)) <-
        fmap (second partitionEithers) $
          foldM goFrom (utTotalValue, []) $
            L.sortOn idx $
              (UET_ReadOnly <$> utFromRO)
                ++ (UET_Linked <$> utFromUnk)
      let f0' = f0 {ueValue = StaticValue f0val}
      let tsLink0 = fmap (unlink (-f0val)) f0links
      (t0val, tsUnk) <-
        fmap (second catMaybes) $
          foldM goTo (-utTotalValue, []) $
            L.sortOn idx2 $
              (UET_Linked <$> (tpairs ++ tsLink0))
                ++ (UET_Unk <$> utToUnk)
                ++ (UET_ReadOnly <$> utToRO)
      let t0 = utTo0 {ueValue = StaticValue t0val}
      return (f0' : fs ++ (t0 : tsUnk))
    where
      project f _ _ (UET_ReadOnly e) = f e
      project _ f _ (UET_Unk e) = f e
      project _ _ f (UET_Linked p) = f p
      idx = project ueIndex ueIndex (ueIndex . fst)
      idx2 = project ueIndex ueIndex ueIndex
      -- TODO the sum accumulator thing is kinda awkward
      goFrom (tot, es) (UET_ReadOnly e) = do
        v <- updateFixed e
        return (tot - v, es)
      goFrom (tot, esPrev) (UET_Unk e) = do
        v <- updateUnknown e
        return (tot - v, Right e {ueValue = StaticValue v} : esPrev)
      goFrom (tot, esPrev) (UET_Linked (e0, es)) = do
        v <- updateUnknown e0
        let e0' = Right $ e0 {ueValue = StaticValue v}
        let es' = fmap (Left . unlink (-v)) es
        return (tot - v, (e0' : es') ++ esPrev)
      goTo (tot, esPrev) (UET_ReadOnly e) = do
        v <- updateFixed e
        return (tot - v, esPrev)
      goTo (tot, esPrev) (UET_Linked e) = do
        v <- updateFixed e
        return (tot - v, Just e : esPrev)
      goTo (tot, esPrev) (UET_Unk e) = do
        v <- updateUnknown e
        return (tot - v, Just e {ueValue = StaticValue v} : esPrev)
      updateFixed :: UpdateEntry i StaticValue -> State EntryBals Rational
      updateFixed e = do
        let v = unStaticValue $ ueValue e
        modify $ mapAdd_ (ueAcnt e, utCurrency) v
        return v
      updateUnknown e = do
        let key = (ueAcnt e, utCurrency)
        curBal <- gets (M.findWithDefault 0 key)
        let v = case ueValue e of
              EVPercent p -> p * curBal
              EVBalance p -> p - curBal
        modify $ mapAdd_ key v
        return v
      unlink v e = e {ueValue = StaticValue $ v * unLinkScale (ueValue e)}

rebalanceFullEntrySet :: FullUpdateEntrySet -> State EntryBals [UEBalanced]
rebalanceFullEntrySet
  UpdateEntrySet
    { utFrom0
    , utTo0
    , -- , utPairs
    utFromUnk
    , utToUnk
    , utFromRO
    , utToRO
    , utCurrency
    -- , utToUnkLink0
    } =
    do
      let (f_ro, f_lnkd) = case utFrom0 of
            Left x -> (x : utFromRO, utFromUnk)
            Right x -> (utFromRO, x : utFromUnk)
      (tpairs, fs) <-
        fmap partitionEithers $
          foldM goFrom [] $
            L.sortOn idx $
              (UET_ReadOnly <$> f_ro)
                ++ (UET_Linked <$> f_lnkd)
      tsUnk <-
        fmap catMaybes $
          foldM goTo [] $
            L.sortOn idx2 $
              (UET_Linked <$> tpairs)
                ++ (UET_Unk <$> utToUnk)
                ++ (UET_ReadOnly <$> utToRO)
      let t0val = -(entrySum fs + entrySum tsUnk)
      let t0 = utTo0 {ueValue = t0val}
      return (fs ++ (t0 : tsUnk))
    where
      project f _ _ (UET_ReadOnly e) = f e
      project _ f _ (UET_Unk e) = f e
      project _ _ f (UET_Linked p) = f p
      idx = project ueIndex ueIndex (ueIndex . fst)
      idx2 = project ueIndex ueIndex ueIndex
      -- TODO the sum accumulator thing is kinda awkward
      goFrom es (UET_ReadOnly e) = do
        _ <- updateFixed e
        return es
      goFrom esPrev (UET_Unk e) = do
        v <- updateUnknown e
        return $ Right e {ueValue = StaticValue v} : esPrev
      goFrom esPrev (UET_Linked (e0, es)) = do
        v <- updateUnknown e0
        let e0' = Right $ e0 {ueValue = StaticValue v}
        let es' = fmap (Left . unlink (-v)) es
        return $ (e0' : es') ++ esPrev
      goTo esPrev (UET_ReadOnly e) = do
        _ <- updateFixed e
        return esPrev
      goTo esPrev (UET_Linked e) = do
        _ <- updateFixed e
        return $ Just e : esPrev
      goTo esPrev (UET_Unk e) = do
        v <- updateUnknown e
        return $ Just e {ueValue = StaticValue v} : esPrev
      updateFixed :: UpdateEntry i StaticValue -> State EntryBals Rational
      updateFixed e = do
        let v = unStaticValue $ ueValue e
        modify $ mapAdd_ (ueAcnt e, utCurrency) v
        return v
      updateUnknown e = do
        let key = (ueAcnt e, utCurrency)
        curBal <- gets (M.findWithDefault 0 key)
        let v = case ueValue e of
              EVPercent p -> p * curBal
              EVBalance p -> p - curBal
        modify $ mapAdd_ key v
        return v
      unlink v e = e {ueValue = StaticValue $ v * unLinkScale (ueValue e)}
      entrySum = sum . fmap ueValue

balanceSecondaryEntrySet
  :: (MonadInsertError m, MonadFinance m)
  => SecondayEntrySet
  -> StateT EntryBals m InsertEntrySet
balanceSecondaryEntrySet
  EntrySet
    { esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
    , esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
    , esCurrency = CurrencyPrec {cpID = curID, cpPrec = precision}
    } =
    do
      fs' <- mapErrors resolveAcntAndTags (f0 :| fs)
      t0' <- resolveAcntAndTags t0
      ts' <- mapErrors resolveAcntAndTags ts
      let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a) curID
      fs'' <- mapErrors balFromEntry fs'
      let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs''
      let balToEntry = balanceEntry (balanceLinked fv curID precision) curID
      ts'' <- mapErrors balToEntry ts'
      -- TODO wet
      let (acntID, sign) = eAcnt t0'
      let t0Val = -(entrySum (NE.toList fs'') + entrySum ts'')
      modify (mapAdd_ (acntID, curID) t0Val)
      let t0'' =
            InsertEntry
              { ieEntry = t0' {eValue = fromIntegral (sign2Int sign) * t0Val, eAcnt = acntID}
              , ieDeferred = Nothing
              }
      -- TODO don't record index here, just keep them in order and let the
      -- insertion function deal with assigning the index
      return $
        InsertEntrySet
          { iesCurrency = curID
          , iesFromEntries = fs''
          , iesToEntries = t0'' :| ts''
          }
    where
      entrySum = sum . fmap (eValue . ieEntry)

balancePrimaryEntrySet
  :: (MonadInsertError m, MonadFinance m)
  => PrimaryEntrySet
  -> StateT EntryBals m InsertEntrySet
balancePrimaryEntrySet
  EntrySet
    { esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
    , esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
    , esCurrency = CurrencyPrec {cpID = curID, cpPrec = precision}
    , esTotalValue
    } =
    do
      let f0res = resolveAcntAndTags f0
      let t0res = resolveAcntAndTags t0
      let fsres = mapErrors resolveAcntAndTags fs
      let tsres = mapErrors resolveAcntAndTags ts
      combineErrorM (combineError f0res fsres (,)) (combineError t0res tsres (,)) $
        \(f0', fs') (t0', ts') -> do
          let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a) curID
          fs'' <- doEntries balFromEntry curID esTotalValue f0' fs'

          let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs''

          let balToEntry = balanceEntry (balanceLinked fv curID precision) curID
          ts'' <- doEntries balToEntry curID (-esTotalValue) t0' ts'
          return $
            InsertEntrySet
              { iesCurrency = curID
              , iesFromEntries = fs''
              , iesToEntries = ts''
              }

doEntries
  :: (MonadInsertError m)
  => (Entry (AccountRId, AcntSign) v TagRId -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId))
  -> CurrencyRId
  -> Rational
  -> Entry (AccountRId, AcntSign) () TagRId
  -> [Entry (AccountRId, AcntSign) v TagRId]
  -> StateT EntryBals m (NonEmpty (InsertEntry AccountRId CurrencyRId TagRId))
doEntries f curID tot e@Entry {eAcnt = (acntID, sign)} es = do
  es' <- mapErrors f es
  let e0val = tot - entrySum es'
  -- TODO not dry
  let s = fromIntegral $ sign2Int sign -- NOTE hack
  modify (mapAdd_ (acntID, curID) e0val)
  let e' =
        InsertEntry
          { ieEntry = e {eValue = s * e0val, eAcnt = acntID}
          , ieDeferred = Nothing
          }
  return $ e' :| es'
  where
    entrySum = sum . fmap (eValue . ieEntry)

liftInnerS :: Monad m => StateT e Identity a -> StateT e m a
liftInnerS = mapStateT (return . runIdentity)

balanceLinked
  :: MonadInsertError m
  => Vector Rational
  -> CurrencyRId
  -> Natural
  -> AccountRId
  -> LinkDeferred Rational
  -> StateT EntryBals m (Rational, Maybe DBDeferred)
balanceLinked from curID precision acntID lg = case lg of
  (LinkIndex LinkedNumGetter {lngIndex, lngScale}) -> do
    let res = fmap (go lngScale) $ from V.!? fromIntegral lngIndex
    case res of
      Just v -> return (v, Just $ EntryLinked lngIndex $ toRational lngScale)
      -- TODO this error would be much more informative if I had access to the
      -- file from which it came
      Nothing -> throwError undefined
  (LinkDeferred d) -> liftInnerS $ balanceDeferred curID acntID d
  where
    go s = roundPrecision precision . (* s) . fromRational

balanceDeferred
  :: CurrencyRId
  -> AccountRId
  -> EntryValue Rational
  -> State EntryBals (Rational, Maybe DBDeferred)
balanceDeferred curID acntID (EntryValue t v) = do
  newval <- findBalance acntID curID t v
  let d = case t of
        TFixed -> Nothing
        TBalance -> Just $ EntryBalance v
        TPercent -> Just $ EntryPercent v
  return (newval, d)

balanceEntry
  :: (MonadInsertError m)
  => (AccountRId -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
  -> CurrencyRId
  -> Entry (AccountRId, AcntSign) v TagRId
  -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId)
balanceEntry f curID e@Entry {eValue, eAcnt = (acntID, sign)} = do
  let s = fromIntegral $ sign2Int sign
  (newVal, deferred) <- f acntID eValue
  modify (mapAdd_ (acntID, curID) newVal)
  return $
    InsertEntry
      { ieEntry = e {eValue = s * newVal, eAcnt = acntID}
      , ieDeferred = deferred
      }

resolveAcntAndTags
  :: (MonadInsertError m, MonadFinance m)
  => Entry AcntID v TagID
  -> m (Entry (AccountRId, AcntSign) v TagRId)
resolveAcntAndTags e@Entry {eAcnt, eTags} = do
  let acntRes = lookupAccount eAcnt
  let tagRes = mapErrors lookupTag eTags
  combineError acntRes tagRes $
    \(acntID, sign, _) tags -> e {eAcnt = (acntID, sign), eTags = tags}

findBalance
  :: AccountRId
  -> CurrencyRId
  -> TransferType
  -> Rational
  -> State EntryBals Rational
findBalance acnt cur t v = do
  curBal <- gets (M.findWithDefault 0 (acnt, cur))
  return $ case t of
    TBalance -> v - curBal
    TPercent -> v * curBal
    TFixed -> v

expandTransfers
  :: (MonadInsertError m, MonadFinance m)
  => TxCommit
  -> DaySpan
  -> [PairedTransfer]
  -> m [Tx TxCommit]
expandTransfers tc bounds = fmap concat . mapErrors (expandTransfer tc bounds)

expandTransfer
  :: (MonadInsertError m, MonadFinance m)
  => TxCommit
  -> DaySpan
  -> PairedTransfer
  -> m [Tx TxCommit]
expandTransfer tc bounds Transfer {transAmounts, transTo, transCurrency, transFrom} = do
  txs <- mapErrors go transAmounts
  return $ concat txs
  where
    go
      Amount
        { amtWhen = pat
        , amtValue = TransferValue {tvVal = v, tvType = t}
        , amtDesc = desc
        } =
        withDates bounds pat $ \day -> do
          p <- entryPair transFrom transTo transCurrency desc () (EntryValue t (toRational (-v)))
          return
            Tx
              { txCommit = tc
              , txDate = day
              , txPrimary = Right p
              , txOther = []
              , txDescr = desc
              }

entryPair
  :: (MonadInsertError m, MonadFinance m)
  => TaggedAcnt
  -> TaggedAcnt
  -> CurID
  -> T.Text
  -> v0
  -> v1
  -> m (EntrySet v0 v1 v2 v3)
entryPair (TaggedAcnt fa fts) (TaggedAcnt ta tts) curid com totval val1 = do
  cp <- lookupCurrency curid
  return $
    EntrySet
      { esCurrency = cp
      , esTotalValue = totval
      , esFrom = halfEntry fa fts val1
      , esTo = halfEntry ta tts ()
      }
  where
    halfEntry :: AcntID -> [TagID] -> v -> HalfEntrySet v v0
    halfEntry a ts v =
      HalfEntrySet
        { hesPrimary = Entry {eAcnt = a, eValue = v, eComment = com, eTags = ts}
        , hesOther = []
        }

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