255 lines
8.5 KiB
Haskell
255 lines
8.5 KiB
Haskell
|
{-# 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 (Range 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 w d p s) = k * (fromIntegral w + (fromIntegral d % (10 ^ p)))
|
||
|
|
where
|
||
|
|
k = if s then 1 else -1
|
||
|
|
|
||
|
|
acntPath2Text :: AcntPath -> T.Text
|
||
|
|
acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)
|