pwncash/lib/Internal/Utils.hs

272 lines
8.1 KiB
Haskell
Raw Normal View History

{-# LANGUAGE FlexibleContexts #-}
2022-12-11 17:51:11 -05:00
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
2022-12-11 17:51:11 -05:00
module Internal.Utils where
import GHC.Real
import Internal.Types
import RIO
import qualified RIO.Map as M
import qualified RIO.Text as T
import qualified RIO.Text.Partial as TP
import RIO.Time
import Text.Regex.TDFA
2022-12-11 17:51:11 -05:00
-- 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 -> (Integer, Int, Int)
gregTup g@Gregorian {..}
| gYear > 99 = error $ show g ++ ": year must only be two digits"
| otherwise =
( fromIntegral gYear + 2000
, fromIntegral gMonth
, fromIntegral gDay
)
gregMTup :: GregorianM -> (Integer, Int)
gregMTup g@GregorianM {..}
| gmYear > 99 = error $ show g ++ ": year must only be two digits"
| otherwise =
( fromIntegral gmYear + 2000
, fromIntegral gmMonth
)
data MDY_ = Y_ Integer | YM_ Integer Int | YMD_ Integer Int Int
fromMatchYMD :: MatchYMD -> MDY_
fromMatchYMD m = case m of
Y y
| y > 99 -> error $ show m ++ ": year must only be two digits"
| otherwise -> Y_ $ fromIntegral y + 2000
YM g -> uncurry YM_ $ gregMTup g
YMD g -> uncurry3 YMD_ $ gregTup g
2022-12-11 17:51:11 -05:00
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')
2022-12-11 17:51:11 -05:00
where
(y, m, d) = toGregorian x
compareDate (In md offset) x = 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
2022-12-11 17:51:11 -05:00
where
(y, m, _) = toGregorian x
compareRange start z
2022-12-11 17:51:11 -05:00
| z < start = LT
2022-12-22 20:13:03 -05:00
| otherwise = if (start + fromIntegral offset - 1) < z then GT else EQ
toMonth year month = (year * 12) + fromIntegral month
2022-12-11 17:51:11 -05:00
dateMatches :: MatchDate -> Day -> Bool
dateMatches md = (EQ ==) . compareDate md
valMatches :: MatchVal -> Rational -> Bool
valMatches MatchVal {..} x =
checkMaybe (s ==) mvSign
&& checkMaybe (n ==) mvNum
&& checkMaybe ((d * p ==) . fromIntegral) mvDen
2022-12-11 17:51:11 -05:00
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
2022-12-11 17:51:11 -05:00
, sValue = evalExp r =<< v
, sCurrency = evalCurrency r c
}
2022-12-11 17:51:11 -05:00
evalAcnt :: TxRecord -> SplitAcnt -> T.Text
evalAcnt TxRecord {trOther = o} s = case s of
2022-12-11 17:51:11 -05:00
ConstT p -> p
LookupT f -> read $ T.unpack $ lookupField f o
2022-12-11 17:51:11 -05:00
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
2022-12-11 17:51:11 -05:00
evalCurrency :: TxRecord -> SplitCur -> T.Text
evalCurrency TxRecord {trOther = o} s = case s of
2022-12-11 17:51:11 -05:00
ConstT p -> p
LookupT f -> lookupField f o
2022-12-11 17:51:11 -05:00
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
2022-12-11 17:51:11 -05:00
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]
2022-12-11 17:51:11 -05:00
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 (=~ trDesc) mDesc
&& all (fieldMatches trOther) mOther
2022-12-11 17:51:11 -05:00
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
2022-12-11 17:51:11 -05:00
(Just v) -> valMatches mv v
_ -> error "you dummy"
2022-12-11 17:51:11 -05:00
Desc (Field n md) -> case M.lookup n dict of
2022-12-24 17:54:20 -05:00
(Just d) -> d =~ md
_ -> error "you dummy"
2022-12-11 17:51:11 -05:00
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
}
2022-12-11 17:51:11 -05:00
where
fromSplit =
Split
{ sAcnt = evalAcnt r sa
, sCurrency = evalCurrency r sc
, sValue = Just trAmount
, sComment = ""
}
2022-12-11 17:51:11 -05:00
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"
2022-12-11 17:51:11 -05:00
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
]
2022-12-11 17:51:11 -05:00
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)
-- TODO don't use a partial function
2022-12-11 17:51:11 -05:00
readRational :: MonadFail m => T.Text -> m Rational
readRational s = case TP.splitOn "." s of
2022-12-11 17:51:11 -05:00
[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
2022-12-11 17:51:11 -05:00
_ -> 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}
2022-12-11 17:51:11 -05:00
boundsFromGregorian :: (Gregorian, Gregorian) -> Bounds
boundsFromGregorian = bimap fromGregorian' fromGregorian'
fromGregorian' :: Gregorian -> Day
fromGregorian' = uncurry3 fromGregorian . gregTup
2022-12-11 17:51:11 -05:00
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} =
2022-12-11 17:51:11 -05:00
(fromGregorian' <$> s, fromGregorian' <$> e)
2023-01-05 22:23:22 -05:00
resolveBounds :: MonadUnliftIO m => MaybeBounds -> m Bounds
2022-12-11 17:51:11 -05:00
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
2022-12-11 17:51:11 -05:00
p = 10 ^ precision
n' = div n d
d' = (\(a :% b) -> div a b) ((x' - fromIntegral n') * p)
2022-12-11 17:51:11 -05:00
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
2022-12-11 17:51:11 -05:00
dec2Rat :: Decimal -> Rational
2022-12-14 23:59:23 -05:00
dec2Rat D {..} =
k * (fromIntegral whole + (fromIntegral decimal % (10 ^ precision)))
2022-12-11 17:51:11 -05:00
where
2022-12-14 23:59:23 -05:00
k = if sign then 1 else -1
2022-12-11 17:51:11 -05:00
acntPath2Text :: AcntPath -> T.Text
acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)