502 lines
16 KiB
Haskell
502 lines
16 KiB
Haskell
{-# 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
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- gregorian
|
|
|
|
gregTup :: Gregorian -> EitherErr (Integer, Int, Int)
|
|
gregTup g@Gregorian {..}
|
|
| gYear > 99 = Left $ YearError $ YMD g
|
|
| otherwise =
|
|
return
|
|
( fromIntegral gYear + 2000
|
|
, fromIntegral gMonth
|
|
, fromIntegral gDay
|
|
)
|
|
|
|
gregMTup :: GregorianM -> EitherErr (Integer, Int)
|
|
gregMTup g@GregorianM {..}
|
|
| gmYear > 99 = Left $ YearError $ YM g
|
|
| 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 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
|
|
|
|
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
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- matching
|
|
|
|
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 . convert) mTx
|
|
else Right MatchFail
|
|
where
|
|
val = valMatches mVal trAmount
|
|
date = maybe (Right 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 -> 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
|
|
checkMaybe = maybe True
|
|
|
|
dateMatches :: MatchDate -> Day -> EitherErr Bool
|
|
dateMatches md = fmap (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
|
|
-- TODO show whole date here since this is kinda useless
|
|
(YearError d) ->
|
|
T.append "Year must be two digits in " $ singleQuote $ showMatchYMD d
|
|
(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 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 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
|
|
|
|
-- | Convert match date to text
|
|
-- This will not throw errors even if year is > 99. 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, " ", showMatchYMD end, ")"]
|
|
where
|
|
end = case start of
|
|
(Y y) -> Y $ y + n
|
|
(YM (GregorianM {..})) ->
|
|
let (y, m) = divMod (gmMonth + n - 1) 12
|
|
in YM $
|
|
GregorianM
|
|
{ gmYear = gmYear + y
|
|
, gmMonth = gmMonth + m + 1
|
|
}
|
|
(YMD (Gregorian {..})) ->
|
|
let (y, m, d) =
|
|
toGregorian $
|
|
addDays (fromIntegral n) $
|
|
fromGregorian
|
|
(fromIntegral gYear)
|
|
(fromIntegral gMonth)
|
|
(fromIntegral gDay)
|
|
in YMD $
|
|
Gregorian
|
|
{ gYear = fromIntegral y
|
|
, gMonth = fromIntegral m
|
|
, gDay = fromIntegral d
|
|
}
|
|
|
|
-- | convert YMD match to text
|
|
-- this will not throw errors even if year is > 99
|
|
showMatchYMD :: MatchYMD -> T.Text
|
|
showMatchYMD md =
|
|
T.intercalate "-" $ L.take 3 (fmap showT digits ++ L.repeat "*")
|
|
where
|
|
digits = case md of
|
|
Y y -> [y]
|
|
YM (GregorianM {..}) -> [gmYear, gmMonth]
|
|
YMD (Gregorian {..}) -> [gYear, gMonth, gDay]
|
|
|
|
showMatchVal :: MatchVal -> Maybe T.Text
|
|
showMatchVal MatchVal {mvSign = Nothing, mvNum = Nothing, mvDen = Nothing} = Nothing
|
|
showMatchVal MatchVal {..} = Just $ T.concat [sign, num, ".", den]
|
|
where
|
|
sign = case mvSign of
|
|
Nothing -> "+/-"
|
|
Just s -> if s then "+" else "-"
|
|
num = maybe "*" showT mvNum
|
|
den = maybe "*" (lpadT '0' (fromIntegral mvPrec) . showT) mvDen
|
|
|
|
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)
|
|
|
|
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
|