pwncash/lib/Internal/Utils.hs

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

module Internal.Utils 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

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

gregTup :: Gregorian -> EitherErr (Integer, Int, Int)
gregTup Gregorian {..}
  | gYear > 99 = Left $ YearError gYear
  | otherwise =
      return
        ( fromIntegral gYear + 2000
        , fromIntegral gMonth
        , fromIntegral gDay
        )

gregMTup :: GregorianM -> EitherErr (Integer, Int)
gregMTup GregorianM {..}
  | gmYear > 99 = Left $ YearError gmYear
  | otherwise =
      return
        ( fromIntegral gmYear + 2000
        , fromIntegral gmMonth
        )

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

fromMatchYMD :: MatchYMD -> EitherErr MDY_
fromMatchYMD m = case m of
  Y y
    | y > 99 -> Left $ YearError y
    | otherwise -> Right $ Y_ $ fromIntegral y + 2000
  YM g -> uncurry YM_ <$> gregMTup g
  YMD g -> uncurry3 YMD_ <$> gregTup g

compareDate :: MatchDate -> Day -> EitherErr Ordering
compareDate (On md) x = do
  res <- fromMatchYMD md
  return $ case res 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
  res <- fromMatchYMD md
  return $ case res 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

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

valMatches :: MatchVal -> Rational -> Bool
valMatches MatchVal {..} x =
  checkMaybe (s ==) mvSign
    && checkMaybe (n ==) mvNum
    && checkMaybe ((d * p ==) . fromIntegral) mvDen
  where
    (n, d) = properFraction $ abs x
    p = 10 ^ mvPrec
    s = signum x >= 0

evalSplit :: TxRecord -> ExpSplit -> EitherErrs RawSplit
evalSplit r s@Split {sAcnt = a, sValue = v, sCurrency = c} =
  concatEither3 (evalAcnt r a) (evalCurrency r c) (mapM (evalExp r) v) $
    \a_ c_ v_ -> (s {sAcnt = a_, sValue = v_, sCurrency = c_})

evalAcnt :: TxRecord -> SplitAcnt -> EitherErr T.Text
evalAcnt TxRecord {trOther = o} s = case s of
  ConstT p -> Right p
  LookupT f -> lookupErr AccountField f o
  MapT (Field f m) -> do
    k <- lookupErr AccountField f o
    lookupErr AccountField k m
  Map2T (Field (f1, f2) m) -> do
    k1 <- lookupErr AccountField f1 o
    k2 <- lookupErr AccountField f2 o
    lookupErr AccountField (k1, k2) m

-- TODO wett codde
evalCurrency :: TxRecord -> SplitCur -> EitherErr T.Text
evalCurrency TxRecord {trOther = o} s = case s of
  ConstT p -> Right p
  LookupT f -> lookupErr CurrencyField f o
  MapT (Field f m) -> do
    k <- lookupErr CurrencyField f o
    lookupErr CurrencyField k m
  Map2T (Field (f1, f2) m) -> do
    k1 <- lookupErr CurrencyField f1 o
    k2 <- lookupErr CurrencyField f2 o
    lookupErr CurrencyField (k1, k2) m

errorT :: T.Text -> a
errorT = error . T.unpack

lookupErr :: (Ord k, Show k) => LookupField -> 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

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

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

fieldMatches :: M.Map T.Text T.Text -> MatchOther -> EitherErr Bool
fieldMatches dict m = case m of
  Val (Field n mv) -> valMatches mv <$> (readRational =<< lookup_ n)
  Desc (Field n md) -> (`matchMaybe` md) =<< lookup_ n
  where
    lookup_ n = case M.lookup n dict of
      Just r -> Right r
      Nothing -> Left $ LookupError OtherField n

checkMaybe :: (a -> Bool) -> Maybe a -> Bool
checkMaybe = maybe True

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 = concatEither2 (evalAcnt r sa) (evalCurrency r sc) (,)
    ssRes = concatEithersL $ fmap (evalSplit r) toSplits

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}

boundsFromGregorian :: (Gregorian, Gregorian) -> EitherErrs Bounds
boundsFromGregorian (a, b) = concatEither2 a_ b_ (,)
  where
    a_ = fromGregorian' a
    b_ = fromGregorian' b

fromGregorian' :: Gregorian -> EitherErr Day
fromGregorian' = fmap (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 -> EitherErrs MaybeBounds
intervalMaybeBounds Interval {intStart = s, intEnd = e} = concatEither2 s_ e_ (,)
  where
    s_ = mapM fromGregorian' s
    e_ = mapM 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

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

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

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

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)

showError :: InsertError -> [T.Text]
showError (StatementError ts ms) = (showTx <$> ts) ++ (showMatch <$> ms)
showError other = (: []) $ case other of
  (YearError y) -> T.append "Year must be two digits: " $ showT y
  (RegexError re) -> T.append "could not make regex from pattern: " re
  (ConversionError x) -> T.append "Could not convert to rational number: " x
  -- TODO use the field indicator
  (LookupError _ f) -> T.append "Could not find field: " f
  (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.concat
      [ 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 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)
      , -- TODO it might be best to always show this
        ("counter", showT <$> n)
      , ("priority", Just $ showT p)
      ]
    others = case o of
      [] -> Nothing
      xs -> Just $ T.concat $ showMatchOther <$> xs

showMatchDate :: MatchDate -> T.Text
showMatchDate md = case md of
  (On x) ->
    let ys = case x of
          Y y -> [y]
          YM (GregorianM {..}) -> [gmYear, gmMonth]
          YMD (Gregorian {..}) -> [gYear, gMonth, gDay]
     in T.intercalate "-" $ L.take 3 (fmap showT ys ++ L.repeat "*")
  (In _ _) -> undefined

-- let ys = case x of
--       Y y -> [y]
--       YM (GregorianM {..}) -> [gmYear, gmMonth]
--       YMD (Gregorian {..}) -> [gYear, gMonth, gDay]
--  in T.intercalate "-" $ L.take 3 (fmap showT ys ++ L.repeat "*")

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

showMatchVal :: MatchVal -> Maybe T.Text
showMatchVal = undefined

showMatchOther :: MatchOther -> T.Text
showMatchOther = undefined

showSplit :: RawSplit -> T.Text
showSplit Split {sAcnt = a, sValue = v, sComment = c} =
  singleQuote $
    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)

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 = first concat . concatEither2 a b

concatEithers3
  :: Either [x] a
  -> Either [x] b
  -> Either [x] c
  -> (a -> b -> c -> d)
  -> Either [x] d
concatEithers3 a b c = first concat . 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 = first concat . 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