module Internal.Utils ( compareDate , inBounds , expandBounds , fmtRational , matches , fromGregorian' , resolveBounds , leftToMaybe , dec2Rat , concatEithers2 , concatEithers3 , concatEither3 , concatEither2 , concatEitherL , concatEithersL , concatEither2M , concatEithers2M , parseRational , showError , unlessLeft_ , unlessLefts_ , unlessLeft , unlessLefts , acntPath2Text , showT , lookupErr , gregorians -- , uncurry3 , xGregToDay , plural , compileMatch , compileOptions , dateMatches , valMatches ) 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.NonEmpty as NE import qualified RIO.Text as T import RIO.Time import Text.Regex.TDFA import Text.Regex.TDFA.Text -------------------------------------------------------------------------------- -- dates -- | find the next date -- this is meant to go in a very tight loop and be very fast (hence no -- complex date functions, most of which heavily use 'mod' and friends) nextXGreg :: XGregorian -> XGregorian nextXGreg XGregorian {xgYear = y, xgMonth = m, xgDay = d, xgDayOfWeek = w} | m == 12 && d == 31 = XGregorian (y + 1) 1 1 w_ | (m == 2 && (not leap && d == 28 || (leap && d == 29))) || (m `elem` [4, 6, 9, 11] && d == 30) || (d == 31) = XGregorian y (m + 1) 1 w_ | otherwise = XGregorian y m (d + 1) w_ where -- don't use DayOfWeek from Data.Time since this uses mod (which uses a -- division opcode) and thus will be slower than just checking for equality -- and adding w_ = if w == 6 then 0 else w + 1 leap = isLeapYear $ fromIntegral y gregorians :: Day -> [XGregorian] gregorians x = L.iterate nextXGreg $ XGregorian (fromIntegral y) m d w where (y, m, d) = toGregorian x w = fromEnum $ dayOfWeek x xGregToDay :: XGregorian -> Day xGregToDay XGregorian {xgYear = y, xgMonth = m, xgDay = d} = fromGregorian (fromIntegral y) m d gregTup :: Gregorian -> (Integer, Int, Int) gregTup Gregorian {gYear, gMonth, gDay} = ( fromIntegral gYear , fromIntegral gMonth , fromIntegral gDay ) gregMTup :: GregorianM -> (Integer, Int) gregMTup GregorianM {gmYear, gmMonth} = ( fromIntegral gmYear , fromIntegral gmMonth ) data YMD_ = Y_ !Integer | YM_ !Integer !Int | YMD_ !Integer !Int !Int fromMatchYMD :: MatchYMD -> YMD_ fromMatchYMD m = case m of Y y -> Y_ $ fromIntegral y YM g -> uncurry YM_ $ gregMTup g YMD g -> uncurry3 YMD_ $ gregTup g 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') where (y, m, d) = toGregorian x compareDate (In md offset) x = do 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 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 fromGregorian' :: Gregorian -> Day fromGregorian' = uncurry3 fromGregorian . gregTup -- TODO misleading name inBounds :: (Day, Day) -> Day -> Bool inBounds (d0, d1) x = d0 <= x && x < d1 resolveBounds :: Interval -> EitherErr Bounds resolveBounds Interval {intStart = s, intEnd = e} = case fromGregorian' <$> e of Nothing -> Right $ toBounds $ fromGregorian' $ s {gYear = gYear s + 50} Just e_ | s_ < e_ -> Right $ toBounds e_ | otherwise -> Left $ BoundsError s e where s_ = fromGregorian' s toBounds end = (s_, fromIntegral $ diffDays end s_ - 1) expandBounds :: Bounds -> (Day, Day) expandBounds (d, n) = (d, addDays (fromIntegral n + 1) d) -------------------------------------------------------------------------------- -- matching matches :: MatchRe -> TxRecord -> EitherErrs (MatchRes RawTx) matches Match {mTx, mOther, mVal, mDate, mDesc} r@TxRecord {trDate, trAmount, trDesc, trOther} = do res <- concatEither3 val other desc $ \x y z -> x && y && z if date && res then maybe (Right MatchSkip) (fmap MatchPass . convert) mTx else Right MatchFail where val = valMatches mVal trAmount date = maybe True (`dateMatches` trDate) mDate other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True mOther desc = maybe (return True) (matchMaybe trDesc . snd) mDesc convert (ToTx cur a ss) = toTx cur a ss r toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> EitherErrs RawTx toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} = 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 -> EitherErr Bool valMatches MatchVal {mvDen, mvSign, mvNum, mvPrec} x | Just d_ <- mvDen, d_ >= p = Left $ MatchValPrecisionError d_ p | otherwise = Right $ checkMaybe (s ==) mvSign && checkMaybe (n ==) mvNum && checkMaybe ((d * fromIntegral p ==) . fromIntegral) mvDen where (n, d) = properFraction $ abs x p = 10 ^ mvPrec s = signum x >= 0 checkMaybe = maybe True dateMatches :: MatchDate -> Day -> Bool dateMatches md = (EQ ==) . compareDate md otherMatches :: M.Map T.Text T.Text -> MatchOtherRe -> 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, Regex) -> T.Text -> m Rational parseRational (pat, re) s = case matchGroupsMaybe s re 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 readT what t = case readMaybe $ T.unpack t of Just d -> return $ fromInteger d _ -> msg $ T.unwords ["could not parse", what, singleQuote t] msg :: MonadFail m => T.Text -> m a msg m = fail $ T.unpack $ T.unwords [m, "-", keyVals [("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 {sign, whole, decimal, precision} = 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 (BoundsError a b) -> T.unwords ["Could not create bounds from", showGregorian_ a, "and", showGreg b] where showGreg (Just g) = showGregorian_ g showGreg Nothing = "Inf" (AccountError a ts) -> T.unwords [ "account type of key" , singleQuote a , "is not one of:" , ts_ ] where ts_ = T.intercalate ", " $ NE.toList $ fmap atName ts (PatternError s b r p) -> T.unwords [msg, "in pattern: ", pat] where pat = keyVals $ [ (k, v) | (k, Just v) <- [ ("start", Just $ showT s) , ("by", Just $ showT b) , ("repeats", showT <$> r) ] ] msg = case p of ZeroLength -> "Zero repeat length" ZeroRepeats -> "Zero repeats" (RegexError re) -> T.append "could not make regex from pattern: " re (ConversionError x) -> T.append "Could not convert to rational number: " x (InsertIOError msg) -> T.append "IO Error: " msg (ParseError msg) -> T.append "Parse Error: " msg (MatchValPrecisionError d p) -> T.unwords ["Match denominator", showT d, "must be less than", showT p] (LookupError t f) -> T.unwords ["Could not find field", singleQuote f, "when resolving", what] where what = case t of SplitIDField st -> T.unwords ["split", idName st, "ID"] SplitValField -> "split value" MatchField mt -> T.unwords [matchName mt, "match"] DBKey st -> T.unwords ["database", idName st, "ID key"] idName AcntField = "account" idName CurField = "currency" matchName MatchNumeric = "numeric" matchName MatchText = "text" (IncomeError dp) -> T.append "Income allocations exceed total: datepattern=" $ showT dp (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 (singleQuote . showSplit) rss showGregorian_ :: Gregorian -> T.Text showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ showT <$> [gYear, gMonth, gDay] 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 :: MatchRe -> 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", fst <$> e) , ("other", others) , ("counter", Just $ maybe "Inf" showT n) , ("priority", Just $ showT p) ] others = case o of [] -> Nothing xs -> Just $ singleQuote $ T.concat $ showMatchOther <$> xs -- | Convert match date to text -- 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, " ", showYMD_ end, ")"] where -- TODO not DRY (this shifting thing happens during the comparison -- function (kinda) end = case fromMatchYMD start of Y_ y -> Y_ $ y + fromIntegral n YM_ y m -> let (y_, m_) = divMod (m + fromIntegral n - 1) 12 in YM_ (y + fromIntegral y_) (m + m_ + 1) YMD_ y m d -> uncurry3 YMD_ $ toGregorian $ addDays (fromIntegral n) $ fromGregorian y m d -- | convert YMD match to text showMatchYMD :: MatchYMD -> T.Text showMatchYMD = showYMD_ . fromMatchYMD showYMD_ :: YMD_ -> T.Text showYMD_ md = T.intercalate "-" $ L.take 3 (fmap showT digits ++ L.repeat "*") where digits = case md of Y_ y -> [fromIntegral y] YM_ y m -> [fromIntegral y, m] YMD_ y m d -> [fromIntegral y, m, d] showMatchVal :: MatchVal -> Maybe T.Text showMatchVal MatchVal {mvSign = Nothing, mvNum = Nothing, mvDen = Nothing} = Nothing showMatchVal MatchVal {mvNum, mvDen, mvSign, mvPrec} = Just $ singleQuote $ keyVals [(k, v) | (k, Just v) <- kvs] where kvs = [ ("sign", (\s -> if s then "+" else "-") <$> mvSign) , ("numerator", showT <$> mvNum) , ("denominator", showT <$> mvDen) , ("precision", Just $ showT mvPrec) ] showMatchOther :: MatchOtherRe -> T.Text showMatchOther (Desc (Field f (re, _))) = T.unwords ["desc field", singleQuote f, "with re", singleQuote re] showMatchOther (Val (Field f mv)) = T.unwords [ "val field" , singleQuote f , "with match value" , singleQuote $ fromMaybe "*" $ showMatchVal mv ] showSplit :: RawSplit -> T.Text showSplit Split {sAcnt = a, sValue = v, sComment = c} = 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] concatEither2M :: Monad m => Either x a -> Either x b -> (a -> b -> m c) -> m (Either [x] c) concatEither2M a b fun = case (a, b) of (Right a_, Right b_) -> Right <$> fun a_ b_ _ -> return $ 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 concatEithers2M :: Monad m => Either [x] a -> Either [x] b -> (a -> b -> m c) -> m (Either [x] c) concatEithers2M a b = fmap merge . concatEither2M 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 (n a)) -> m (n a) unlessLeft (Left es) _ = return (return es) unlessLeft (Right rs) f = f rs unlessLefts :: (Monad m) => Either (n a) b -> (b -> m (n a)) -> m (n a) unlessLefts (Left es) _ = return es unlessLefts (Right rs) f = f rs unlessLeft_ :: (Monad m, MonadPlus n) => Either a b -> (b -> m ()) -> m (n a) unlessLeft_ e f = unlessLeft e (\x -> void (f x) >> return mzero) unlessLefts_ :: (Monad m, MonadPlus n) => Either (n a) b -> (b -> m ()) -> m (n a) unlessLefts_ e f = unlessLefts e (\x -> void (f x) >> 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 -- TODO this regular expression appears to be compiled each time, which is -- super slow -- NOTE: see https://github.com/haskell-hvr/regex-tdfa/issues/9 - performance -- is likely not going to be optimal for text -- matchMaybe :: T.Text -> T.Text -> EitherErr Bool -- matchMaybe q pat = case compres of -- Right re -> case execute re q of -- Right res -> Right $ isJust res -- Left _ -> Left $ RegexError "this should not happen" -- Left _ -> Left $ RegexError pat -- where -- -- these options barely do anything in terms of performance -- compres = compile (blankCompOpt {newSyntax = True}) (blankExecOpt {captureGroups = False}) pat compileOptions :: TxOpts T.Text -> EitherErr TxOptsRe compileOptions o@TxOpts {toAmountFmt = pat} = do re <- compileRegex True pat return $ o {toAmountFmt = re} compileMatch :: Match T.Text -> EitherErrs MatchRe compileMatch m@Match {mDesc = d, mOther = os} = do let dres = plural $ mapM go d let ores = concatEitherL $ fmap (mapM go) os concatEithers2 dres ores $ \d_ os_ -> m {mDesc = d_, mOther = os_} where go = compileRegex False compileRegex :: Bool -> T.Text -> EitherErr (Text, Regex) compileRegex groups pat = case res of Right re -> Right (pat, re) Left _ -> Left $ RegexError pat where res = compile (blankCompOpt {newSyntax = True}) (blankExecOpt {captureGroups = groups}) pat matchMaybe :: T.Text -> Regex -> EitherErr Bool matchMaybe q re = case execute re q of Right res -> Right $ isJust res Left _ -> Left $ RegexError "this should not happen" matchGroupsMaybe :: T.Text -> Regex -> [T.Text] matchGroupsMaybe q re = case regexec re q of Right Nothing -> [] Right (Just (_, _, _, xs)) -> xs -- this should never fail as regexec always returns Right Left _ -> []