pwncash/lib/Internal/Utils.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Internal.Utils
  ( compareDate
  , intervalMaybeBounds
  , fmtRational
  , matches
  , fromGregorian'
  , resolveBounds
  , leftToMaybe
  , dec2Rat
  , concatEithers2
  , concatEither2
  , parseRational
  , showError
  , unlessLeft
  , unlessLefts
  , inMaybeBounds
  , acntPath2Text
  , showT
  )
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.Text as T
import RIO.Time
import Text.Regex.TDFA

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

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

gregMTup :: GregorianM -> (Integer, Int)
gregMTup GregorianM {..} =
  ( 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

-- boundsFromGregorian :: (Gregorian, Gregorian) -> Bounds
-- boundsFromGregorian (a, b) = (fromGregorian' a, fromGregorian' b)

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

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

inMaybeBounds :: MaybeBounds -> Day -> Bool
inMaybeBounds (d0, d1) x = maybe True (x >=) d0 && maybe True (x <=) d1

intervalMaybeBounds :: Interval -> MaybeBounds
intervalMaybeBounds Interval {intStart = s, intEnd = e} =
  (fmap fromGregorian' s, fmap fromGregorian' e)

resolveBounds :: MonadUnliftIO m => MaybeBounds -> m Bounds
resolveBounds (s, e) = do
  s' <- maybe getDay return s
  e' <- maybe (addGregorianYearsClip 50 <$> getDay) return e
  return (s', e')
  where
    getDay = utctDay <$> getCurrentTime

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

matches :: Match -> TxRecord -> EitherErrs (MatchRes RawTx)
matches Match {..} r@TxRecord {..} = 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) mDesc
    convert (ToTx cur a ss) = toTx cur a ss r

toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> EitherErrs RawTx
toTx sc sa toSplits r@TxRecord {..} =
  concatEithers2 acRes ssRes $ \(a_, c_) ss_ ->
    let fromSplit =
          Split
            { sAcnt = a_
            , sCurrency = c_
            , sValue = Just trAmount
            , sComment = ""
            }
     in Tx
          { txTags = []
          , 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 {..} 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 -> MatchOther -> 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 -> T.Text -> m Rational
parseRational pat s = case ms 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
    (_, _, _, ms) = (s =~ pat) :: (T.Text, T.Text, T.Text, [T.Text])
    readT what t = case readMaybe $ T.unpack t of
      Just d -> return $ fromInteger d
      _ -> msg $ T.unwords ["could not parse", what, t]
    msg m =
      fail $
        T.unpack $
          T.concat
            [ m
            , "; 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 {..} =
  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
  (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
  (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"
            , case st of AcntField -> "account"; CurField -> "currency"
            , "ID"
            ]
        SplitValField -> "split value"
        MatchField mt ->
          T.unwords
            [ case mt of MatchNumeric -> "numeric"; MatchText -> "text"
            , "match"
            ]
  (AllocationError t dp) -> T.concat [msg, ": datepattern=", showT dp]
    where
      msg = case t of
        NoAllocations -> "No post-tax allocations present"
        ExceededTotal -> "Allocations exceed total income"
        MissingBlank -> "No blank allocation to balance"
        TooManyBlanks -> "Cannot balance multiple blank allocations"
  (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

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 :: Match -> 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", 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 {..} = 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 :: MatchOther -> 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]

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

-- 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 ()) -> m (n a)
unlessLeft (Left es) _ = return (return es)
unlessLeft (Right rs) f = f rs >> return mzero

unlessLefts :: (Monad m, MonadPlus n) => Either (n a) b -> (b -> m ()) -> m (n a)
unlessLefts (Left es) _ = return es
unlessLefts (Right rs) f = f rs >> 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

matchMaybe :: RegexContext Regex query b => query -> T.Text -> EitherErr b
matchMaybe q re = first (const $ RegexError re) $ pureTry $ q =~ re