pwncash/lib/Internal/Utils.hs

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

module Internal.Utils where

import           Data.Bifunctor
import qualified Data.Map        as M
import           Data.Ratio
import qualified Data.Text       as T
import           Data.Time

import           GHC.Real

import           Numeric.Natural

import           Internal.Types

import           Text.Read
import           Text.Regex.TDFA

descMatches :: MatchDesc -> T.Text -> Bool
descMatches (Re re)   = (=~ re)
descMatches (Exact t) = (== t)

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

toGregorianI :: (Integral a, Integral b, Integral c) => Day -> (a, b, c)
toGregorianI = thrice fromIntegral fromIntegral fromIntegral . toGregorian

fromGregorianI :: Natural -> Natural -> Natural -> Day
fromGregorianI y m d =
  fromGregorian (fromIntegral y) (fromIntegral m) (fromIntegral d)

toModifiedJulianDayI :: Day -> Natural
toModifiedJulianDayI = fromIntegral . toModifiedJulianDay

compareDate :: MatchDate -> Day -> Ordering
compareDate (On md) x = case md of
  Y y'                     -> compare sY y'
  YM (GregorianM y' m')    -> compare (sY, m) (y', m')
  YMD (Gregorian y' m' d') -> compare (sY, m, d) (y', m', d')
  where
    -- TODO make this actually give a real gregorian type, which will clean
    -- this up
    (y, m, d) = toGregorianI x
    sY = y2k y
compareDate (In md o) x = case md of
  Y y'                     -> compareRange y' o sY
  YM (GregorianM y' m')    -> let s = toMonth y' m' in compareRange s o $ toMonth sY m
  YMD (Gregorian y' m' d') ->
    let s = toModifiedJulianDayI $ fromGregorianI (y' + 2000) m' d'
    in compareRange s o $ toModifiedJulianDayI x
  where
    (y, m, _) = toGregorianI x :: (Natural, Natural, Natural)
    sY = y2k y
    compareRange start offset z
      | z < start = LT
      | otherwise = if (start + offset) < z then GT else EQ
    toMonth year month = (year * 12) + month

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

-- this apparently can't be eta reduced without triggering an underflow
y2k :: Natural -> Natural
y2k x = x - 2000

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 -> RawSplit
evalSplit r s@Split { sAcnt = a, sValue = v, sCurrency = c } =
  s { sAcnt = evalAcnt r a
    , sValue = evalExp r =<< v
    , sCurrency = evalCurrency r c }

evalAcnt :: TxRecord -> SplitAcnt -> T.Text
evalAcnt TxRecord { trOther = o } s = case s of
  ConstT p -> p
  LookupT f                -> read $ T.unpack $ lookupField f o
  MapT (Field f m) -> let k = lookupField f o in lookupErr "account key" k m
  Map2T (Field (f1, f2) m) -> let k1 = lookupField f1 o
                                  k2 = lookupField f2 o
                              in lookupErr "account key" (k1, k2) m

evalCurrency :: TxRecord -> SplitCur -> T.Text
evalCurrency TxRecord { trOther = o } s = case s of
  ConstT p -> p
  LookupT f                -> lookupField f o
  MapT (Field f m) -> let k = lookupField f o in lookupErr "currency key" k m
  Map2T (Field (f1, f2) m) -> let k1 = lookupField f1 o
                                  k2 = lookupField f2 o
                              in lookupErr "currency key" (k1, k2) m

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

lookupField :: (Ord k, Show k) => k -> M.Map k v -> v
lookupField = lookupErr "field"

lookupErr :: (Ord k, Show k) => T.Text -> k -> M.Map k v -> v
lookupErr what k m = case M.lookup k m of
  Just x -> x
  _      -> errorT $ T.concat [what, " does not exist: ", T.pack $ show k]

matches :: Match -> TxRecord -> Maybe (Maybe RawTx)
matches Match {..} r@TxRecord {..}
  | allPass = Just $ fmap eval mTx
  | otherwise = Nothing
  where
    allPass = checkMaybe (`dateMatches` trDate) mDate
      && valMatches mVal trAmount
      && checkMaybe (`descMatches` trDesc) mDesc
      && all (fieldMatches trOther) mOther
    eval (ToTx cur a ss) = toTx cur a ss r

-- TODO these error messages are useless
fieldMatches :: M.Map T.Text T.Text -> MatchOther -> Bool
fieldMatches dict m = case m of
  Val (Field n mv)  -> case readRational =<< M.lookup n dict of
    (Just v) -> valMatches mv v
    _        -> error "you dummy"
  Desc (Field n md) -> case M.lookup n dict of
    (Just d) -> descMatches md d
    _        -> error "you dummy"

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

toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> RawTx
toTx sc sa toSplits r@TxRecord {..} =
  Tx { txTags = []
     , txDate = trDate
     , txDescr = trDesc
     , txSplits = fromSplit:fmap (evalSplit r) toSplits
     }
  where
    fromSplit = Split { sAcnt = evalAcnt r sa
                      , sCurrency = evalCurrency r sc
                      , sValue = Just trAmount
                      , sComment = ""
                      }

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 :: MonadFail m => T.Text -> m Rational
readRational s = case T.splitOn "." s of
  [x] -> return $ fromInteger $ readT x
  [x, y] -> let x' = readT x
                y' = readT y
                p = 10 ^ T.length y
                k = if x' >= 0 then 1 else -1 in
              if y' > p
              then fail "not enough precision to parse"
              else return $ fromInteger x' + k * y' % p
  _ -> fail $ T.unpack $ T.append "malformed decimal: " s
  where
    readT = read . T.unpack

-- 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) -> Bounds
boundsFromGregorian = bimap fromGregorian' fromGregorian'

fromGregorian' :: Gregorian -> Day
fromGregorian' (Gregorian y m d) = fromGregorianI y m d

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 } =
  (fromGregorian' <$> s, fromGregorian' <$> e)

resolveBounds :: MaybeBounds -> IO 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' = toInteger $ div n d
    d' = toInteger $ (\(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 -> Maybe Rational
evalExp r s = case s of
  (LookupN t) -> readRational =<< M.lookup t (trOther r)
  (ConstN c)  -> Just $ dec2Rat c
  AmountN     -> Just $ 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)