pwncash/lib/Internal/Utils.hs

module Internal.Utils
  ( compareDate
  , inBounds
  , expandBounds
  , fmtRational
  , matches
  , fromGregorian'
  , resolveBounds
  , leftToMaybe
  , dec2Rat
  , concatEithers2
  , concatEithers3
  , concatEither3
  , concatEither2
  , concatEitherL
  , concatEithersL
  , concatEither2M
  , concatEithers2M
  , parseRational
  , showError
  , unlessLeft_
  , unlessLefts_
  , unlessLeft
  , unlessLefts
  , acntPath2Text
  , showT
  , lookupErr
  , gregorians
  -- , uncurry3

  , xGregToDay
  , plural
  , compileMatch
  , compileOptions
  , dateMatches
  , valMatches
  )
where

import Data.Time.Format.ISO8601
import GHC.Real
import Internal.Types
import RIO
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
import Text.Regex.TDFA
import Text.Regex.TDFA.Text

--------------------------------------------------------------------------------
-- dates

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

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

compareDate :: MatchDate -> Day -> Ordering
compareDate (On md) x =
  case fromMatchYMD md of
    Y_ y' -> compare y y'
    YM_ y' m' -> compare (y, m) (y', m')
    YMD_ y' m' d' -> compare (y, m, d) (y', m', d')
  where
    (y, m, d) = toGregorian x
compareDate (In md offset) x = do
  case fromMatchYMD md of
    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

-- TODO misleading name
inBounds :: (Day, Day) -> Day -> Bool
inBounds (d0, d1) x = d0 <= x && x < d1

resolveBounds :: Interval -> EitherErr Bounds
resolveBounds Interval {intStart = s, intEnd = e} =
  case fromGregorian' <$> e of
    Nothing -> Right $ toBounds $ fromGregorian' $ s {gYear = gYear s + 50}
    Just e_
      | s_ < e_ -> Right $ toBounds e_
      | otherwise -> Left $ BoundsError s e
  where
    s_ = fromGregorian' s
    toBounds end = (s_, fromIntegral $ diffDays end s_ - 1)

expandBounds :: Bounds -> (Day, Day)
expandBounds (d, n) = (d, addDays (fromIntegral n + 1) d)

--------------------------------------------------------------------------------
-- matching

matches :: MatchRe -> TxRecord -> EitherErrs (MatchRes RawTx)
matches
  Match {mTx, mOther, mVal, mDate, mDesc}
  r@TxRecord {trDate, trAmount, trDesc, trOther} = do
    res <- concatEither3 val other desc $ \x y z -> x && y && z
    if date && res
      then maybe (Right MatchSkip) (fmap MatchPass . convert) mTx
      else Right MatchFail
    where
      val = valMatches mVal trAmount
      date = maybe True (`dateMatches` trDate) mDate
      other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True mOther
      desc = maybe (return True) (matchMaybe trDesc . snd) mDesc
      convert (ToTx cur a ss) = toTx cur a ss r

toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> EitherErrs RawTx
toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} =
  concatEithers2 acRes ssRes $ \(a_, c_) ss_ ->
    let fromSplit =
          Split
            { sAcnt = a_
            , sCurrency = c_
            , sValue = Just trAmount
            , sComment = ""
            , sTags = [] -- TODO what goes here?
            }
     in Tx
          { txDate = trDate
          , txDescr = trDesc
          , txSplits = fromSplit : ss_
          }
  where
    acRes = concatEithers2 (resolveAcnt r sa) (resolveCurrency r sc) (,)
    ssRes = concatEithersL $ fmap (resolveSplit r) toSplits

valMatches :: MatchVal -> Rational -> EitherErr Bool
valMatches MatchVal {mvDen, mvSign, mvNum, mvPrec} x
  | Just d_ <- mvDen, d_ >= p = Left $ MatchValPrecisionError d_ p
  | otherwise =
      Right $
        checkMaybe (s ==) mvSign
          && checkMaybe (n ==) mvNum
          && checkMaybe ((d * fromIntegral p ==) . fromIntegral) mvDen
  where
    (n, d) = properFraction $ abs x
    p = 10 ^ mvPrec
    s = signum x >= 0
    checkMaybe = maybe True

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

otherMatches :: M.Map T.Text T.Text -> MatchOtherRe -> EitherErr 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

resolveSplit :: TxRecord -> ExpSplit -> EitherErrs RawSplit
resolveSplit r s@Split {sAcnt = a, sValue = v, sCurrency = c} =
  concatEithers2 acRes valRes $
    \(a_, c_) v_ -> (s {sAcnt = a_, sValue = v_, sCurrency = c_})
  where
    acRes = concatEithers2 (resolveAcnt r a) (resolveCurrency r c) (,)
    valRes = plural $ mapM (resolveValue r) v

resolveValue :: TxRecord -> SplitNum -> EitherErr Rational
resolveValue r s = case s of
  (LookupN t) -> readRational =<< lookupErr SplitValField t (trOther r)
  (ConstN c) -> Right $ dec2Rat c
  AmountN -> Right $ trAmount r

resolveAcnt :: TxRecord -> SplitAcnt -> EitherErrs T.Text
resolveAcnt = resolveSplitField AcntField

resolveCurrency :: TxRecord -> SplitCur -> EitherErrs T.Text
resolveCurrency = resolveSplitField CurField

resolveSplitField :: SplitIDType -> TxRecord -> SplitAcnt -> EitherErrs T.Text
resolveSplitField t TxRecord {trOther = o} s = case s of
  ConstT p -> Right p
  LookupT f -> plural $ lookup_ f o
  MapT (Field f m) -> plural $ do
    k <- lookup_ f o
    lookup_ k m
  Map2T (Field (f1, f2) m) -> do
    (k1, k2) <- concatEither2 (lookup_ f1 o) (lookup_ f2 o) (,)
    plural $ lookup_ (k1, k2) m
  where
    lookup_ :: (Ord k, Show k) => k -> M.Map k v -> EitherErr v
    lookup_ = lookupErr (SplitIDField t)

lookupErr :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> EitherErr v
lookupErr what k m = case M.lookup k m of
  Just x -> Right x
  _ -> Left $ 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)

readRational :: T.Text -> EitherErr 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 = Left $ 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

dec2Rat :: Decimal -> Rational
dec2Rat D {sign, whole, decimal, precision} =
  k * (fromIntegral whole + (fromIntegral decimal % (10 ^ precision)))
  where
    k = if sign then 1 else -1

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

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

showError :: InsertError -> [T.Text]
showError (StatementError ts ms) = (showTx <$> ts) ++ (showMatch <$> ms)
showError other = (: []) $ case other of
  (BoundsError 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", singleQuote f, "when resolving", what]
    where
      what = case t of
        SplitIDField st -> T.unwords ["split", idName st, "ID"]
        SplitValField -> "split 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 dp) ->
    T.append "Income allocations exceed total: datepattern=" $ showT dp
  (BalanceError t cur rss) ->
    T.unwords
      [ msg
      , "for currency"
      , singleQuote cur
      , "and for splits"
      , splits
      ]
    where
      msg = case t of
        TooFewSplits -> "Need at least two splits to balance"
        NotOneBlank -> "Exactly one split must be blank"
      splits = T.intercalate ", " $ fmap (singleQuote . showSplit) rss

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 Match {mDate = d, mVal = v, mDesc = e, mOther = o, mTimes = n, mPriority = p} =
  T.append "Unused match: " $ keyVals [(x, y) | (x, Just y) <- kvs]
  where
    kvs =
      [ ("date", showMatchDate <$> d)
      , ("val", showMatchVal v)
      , ("desc", fst <$> e)
      , ("other", others)
      , ("counter", Just $ maybe "Inf" showT n)
      , ("priority", Just $ showT p)
      ]
    others = case o 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)
showMatchDate :: MatchDate -> T.Text
showMatchDate md = case md of
  (On x) -> showMatchYMD x
  (In start n) -> T.concat ["[", showMatchYMD start, " ", showYMD_ end, ")"]
    where
      -- TODO not DRY (this shifting thing happens during the comparison
      -- function (kinda)
      end = case fromMatchYMD 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
showMatchYMD :: MatchYMD -> T.Text
showMatchYMD = showYMD_ . fromMatchYMD

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]

showMatchVal :: MatchVal -> Maybe T.Text
showMatchVal MatchVal {mvSign = Nothing, mvNum = Nothing, mvDen = Nothing} = Nothing
showMatchVal MatchVal {mvNum, mvDen, mvSign, mvPrec} =
  Just $ singleQuote $ keyVals [(k, v) | (k, Just v) <- kvs]
  where
    kvs =
      [ ("sign", (\s -> if s then "+" else "-") <$> mvSign)
      , ("numerator", showT <$> mvNum)
      , ("denominator", showT <$> mvDen)
      , ("precision", Just $ showT mvPrec)
      ]

showMatchOther :: MatchOtherRe -> 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 "*" $ showMatchVal mv
    ]

showSplit :: RawSplit -> T.Text
showSplit Split {sAcnt = a, sValue = v, sComment = c} =
  keyVals
    [ ("account", a)
    , ("value", T.pack $ show ((fromRational <$> v) :: Maybe Float))
    , ("comment", doubleQuote c)
    ]

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)

uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 f (a, b, c) = f a b 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 -> EitherErr TxOptsRe
compileOptions o@TxOpts {toAmountFmt = pat} = do
  re <- compileRegex True pat
  return $ o {toAmountFmt = re}

compileMatch :: Match T.Text -> EitherErrs MatchRe
compileMatch m@Match {mDesc = d, mOther = os} = do
  let dres = plural $ mapM go d
  let ores = concatEitherL $ fmap (mapM go) os
  concatEithers2 dres ores $ \d_ os_ -> m {mDesc = d_, mOther = os_}
  where
    go = compileRegex False

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

matchMaybe :: T.Text -> Regex -> EitherErr Bool
matchMaybe q re = case execute re q of
  Right res -> Right $ isJust res
  Left _ -> Left $ 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 _ -> []