diff --git a/dhall/Types.dhall b/dhall/Types.dhall index c24ddea..fe90f1c 100644 --- a/dhall/Types.dhall +++ b/dhall/Types.dhall @@ -984,54 +984,35 @@ let Income = } } -let AcntSet = - {- - A list of account IDs represented as a set. - -} - { Type = - { asList : List AcntID - , asInclude : - {- - If true, tests for account membership in this set will return - true if the account is in the set. Invert this behavior otherwise. - -} - Bool - } - , default = { asList = [] : List AcntID, asInclude = False } - } - -let TransferMatcher = +let TransferMatcher_ = {- Means to match a transfer (which will be used to "clone" it in some fashion) -} - { Type = - { tmFrom : - {- - List of accounts (which may be empty) to match with the - starting account in a transfer. - -} - AcntSet.Type - , tmTo : - {- - List of accounts (which may be empty) to match with the - ending account in a transfer. - -} - AcntSet.Type - , tmDate : - {- - If given, means to match the date of a transfer. - -} - Optional DateMatcher - , tmVal : - {- - If given, means to match the value of a transfer. - -} - ValMatcher.Type - } + \(re : Type) -> + { tmFrom : + {- + Regex pattern by which matching account ids will be identified + -} + Optional re + , tmTo : Optional re + , tmDate : + {- + If given, means to match the date of a transfer. + -} + Optional DateMatcher + , tmVal : + {- + If given, means to match the value of a transfer. + -} + ValMatcher.Type + } + +let TransferMatcher = + { Type = TransferMatcher_ Text , default = - { tmFrom = AcntSet.default - , tmTo = AcntSet.default + { tmFrom = None Text + , tmTo = None Text , tmDate = None DateMatcher , tmVal = ValMatcher.default } @@ -1148,9 +1129,9 @@ in { CurID , Budget , Allocation , Amount + , TransferMatcher_ , TransferMatcher , ShadowTransfer - , AcntSet , TaggedAcnt , AccountTree , Account diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs index f19126b..bce154b 100644 --- a/lib/Internal/Budget.hs +++ b/lib/Internal/Budget.hs @@ -345,26 +345,31 @@ fromShadow -> ShadowTransfer -> m (Maybe ShadowEntrySet) fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} = - combineErrorM curRes shaRes $ \cur sha -> do + combineErrorM curRes mRes $ \cur compiled -> do + res <- liftExcept $ shadowMatches compiled tx let es = entryPair stFrom stTo cur stDesc stRatio () - return $ if not sha then Nothing else Just es + return $ if not res then Nothing else Just es where - curRes = lookupCurrencyKey (CurID stCurrency) - shaRes = liftExcept $ shadowMatches stMatch tx + curRes = lookupCurrencyKey stCurrency + mRes = liftExcept $ compileMatch stMatch -shadowMatches :: TransferMatcher -> Tx CommitR -> AppExcept Bool +shadowMatches :: TransferMatcherRe -> Tx CommitR -> AppExcept Bool shadowMatches - TransferMatcher {tmFrom, tmTo, tmDate, tmVal} + TransferMatcher_ {tmFrom, tmTo, tmDate, tmVal} Tx {txPrimary, txMeta = TxMeta {txmDate}} = do + -- ASSUME these will never fail and thus I don't need to worry about + -- stacking the errors + fromRes <- acntMatches fa tmFrom + toRes <- acntMatches ta tmTo -- NOTE this will only match against the primary entry set since those -- are what are guaranteed to exist from a transfer valRes <- case txPrimary of Left es -> valMatches tmVal $ toRational $ esTotalValue es Right _ -> return True return $ - memberMaybe fa tmFrom - && memberMaybe ta tmTo + fromRes + && toRes && maybe True (`dateMatches` txmDate) tmDate && valRes where @@ -373,8 +378,18 @@ shadowMatches getAcntFrom = getAcnt esFrom getAcntTo = getAcnt esTo getAcnt f = eAcnt . hesPrimary . f - memberMaybe x AcntSet {asList, asInclude} = - (if asInclude then id else not) $ x `elem` (AcntID <$> asList) + acntMatches (AcntID a) = maybe (return True) (matchMaybe a) + +compileMatch :: TransferMatcher_ T.Text -> AppExcept TransferMatcherRe +compileMatch m@TransferMatcher_ {tmTo, tmFrom} = + combineError tres fres $ \t f -> m {tmTo = t, tmFrom = f} + where + go = fmap snd . compileRegex False + tres = mapM go tmTo + fres = mapM go tmFrom + +-- memberMaybe x AcntSet {asList, asInclude} = +-- (if asInclude then id else not) $ x `elem` (AcntID <$> asList) -------------------------------------------------------------------------------- -- random diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs index cf51b8b..67c879e 100644 --- a/lib/Internal/History.hs +++ b/lib/Internal/History.hs @@ -23,7 +23,6 @@ import qualified RIO.Text as T import RIO.Time import qualified RIO.Vector as V import Text.Regex.TDFA hiding (matchAll) -import Text.Regex.TDFA.Text readHistoryCRUD :: (MonadUnliftIO m, MonadFinance m) @@ -124,28 +123,28 @@ parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFm d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d return $ Just $ TxRecord d' a e os p -matchRecords :: MonadFinance m => [MatchRe] -> [TxRecord] -> AppExceptT m [Tx ()] +matchRecords :: MonadFinance m => [StatementParserRe] -> [TxRecord] -> AppExceptT m [Tx ()] matchRecords ms rs = do (matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs case (matched, unmatched, notfound) of (ms_, [], []) -> return ms_ (_, us, ns) -> throwError $ AppException [StatementError us ns] -matchPriorities :: [MatchRe] -> [MatchGroup] +matchPriorities :: [StatementParserRe] -> [MatchGroup] matchPriorities = fmap matchToGroup . L.groupBy (\a b -> spPriority a == spPriority b) . L.sortOn (Down . spPriority) -matchToGroup :: [MatchRe] -> MatchGroup +matchToGroup :: [StatementParserRe] -> MatchGroup matchToGroup ms = uncurry MatchGroup $ first (L.sortOn spDate) $ L.partition (isJust . spDate) ms data MatchGroup = MatchGroup - { mgDate :: ![MatchRe] - , mgNoDate :: ![MatchRe] + { mgDate :: ![StatementParserRe] + , mgNoDate :: ![StatementParserRe] } deriving (Show) @@ -184,9 +183,9 @@ zipperSlice f x = go zipperMatch :: MonadFinance m - => Unzipped MatchRe + => Unzipped StatementParserRe -> TxRecord - -> AppExceptT m (Zipped MatchRe, MatchRes (Tx ())) + -> AppExceptT m (Zipped StatementParserRe, MatchRes (Tx ())) zipperMatch (Unzipped bs cs as) x = go [] cs where go _ [] = return (Zipped bs $ cs ++ as, MatchFail) @@ -201,9 +200,9 @@ zipperMatch (Unzipped bs cs as) x = go [] cs zipperMatch' :: MonadFinance m - => Zipped MatchRe + => Zipped StatementParserRe -> TxRecord - -> AppExceptT m (Zipped MatchRe, MatchRes (Tx ())) + -> AppExceptT m (Zipped StatementParserRe, MatchRes (Tx ())) zipperMatch' z x = go z where go (Zipped bs (a : as)) = do @@ -214,7 +213,7 @@ zipperMatch' z x = go z return (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass) go z' = return (z', MatchFail) -matchDec :: MatchRe -> Maybe MatchRe +matchDec :: StatementParserRe -> Maybe StatementParserRe matchDec m = case spTimes m of Just 1 -> Nothing Just n -> Just $ m {spTimes = Just $ n - 1} @@ -224,7 +223,7 @@ matchAll :: MonadFinance m => [MatchGroup] -> [TxRecord] - -> AppExceptT m ([Tx ()], [TxRecord], [MatchRe]) + -> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe]) matchAll = go ([], []) where go (matched, unused) gs rs = case (gs, rs) of @@ -238,7 +237,7 @@ matchGroup :: MonadFinance m => MatchGroup -> [TxRecord] - -> AppExceptT m ([Tx ()], [TxRecord], [MatchRe]) + -> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe]) matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do (md, rest, ud) <- matchDates ds rs (mn, unmatched, un) <- matchNonDates ns rest @@ -246,9 +245,9 @@ matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do matchDates :: MonadFinance m - => [MatchRe] + => [StatementParserRe] -> [TxRecord] - -> AppExceptT m ([Tx ()], [TxRecord], [MatchRe]) + -> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe]) matchDates ms = go ([], [], initZipper ms) where go (matched, unmatched, z) [] = @@ -271,9 +270,9 @@ matchDates ms = go ([], [], initZipper ms) matchNonDates :: MonadFinance m - => [MatchRe] + => [StatementParserRe] -> [TxRecord] - -> AppExceptT m ([Tx ()], [TxRecord], [MatchRe]) + -> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe]) matchNonDates ms = go ([], [], initZipper ms) where go (matched, unmatched, z) [] = @@ -290,7 +289,11 @@ matchNonDates ms = go ([], [], initZipper ms) MatchFail -> (matched, r : unmatched) in go (m, u, resetZipper z') rs -matches :: MonadFinance m => MatchRe -> TxRecord -> AppExceptT m (MatchRes (Tx ())) +matches + :: MonadFinance m + => StatementParserRe + -> TxRecord + -> AppExceptT m (MatchRes (Tx ())) matches StatementParser {spTx, spOther, spVal, spDate, spDesc, spPriority} r@TxRecord {trDate, trAmount, trDesc, trOther} = do @@ -469,7 +472,7 @@ compileOptions o@TxOpts {toAmountFmt = pat} = do re <- compileRegex True pat return $ o {toAmountFmt = re} -compileMatch :: StatementParser T.Text -> AppExcept MatchRe +compileMatch :: StatementParser T.Text -> AppExcept StatementParserRe compileMatch m@StatementParser {spDesc, spOther} = do combineError dres ores $ \d os -> m {spDesc = d, spOther = os} where @@ -477,29 +480,6 @@ compileMatch m@StatementParser {spDesc, spOther} = do dres = mapM go spDesc ores = combineErrors $ fmap (mapM go) spOther -compileRegex :: Bool -> T.Text -> AppExcept (Text, Regex) -compileRegex groups pat = case res of - Right re -> return (pat, re) - Left _ -> throwError $ AppException [RegexError pat] - where - res = - compile - (blankCompOpt {newSyntax = True}) - (blankExecOpt {captureGroups = groups}) - pat - -matchMaybe :: T.Text -> Regex -> AppExcept Bool -matchMaybe q re = case execute re q of - Right res -> return $ isJust res - Left _ -> throwError $ AppException [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 _ -> [] - parseDecimal :: MonadFail m => (T.Text, Regex) -> T.Text -> m Decimal parseDecimal (pat, re) s = case matchGroupsMaybe s re of [sign, x, ""] -> Decimal 0 . uncurry (*) <$> readWhole sign x diff --git a/lib/Internal/Types/Dhall.hs b/lib/Internal/Types/Dhall.hs index 1a72ea3..ef26bde 100644 --- a/lib/Internal/Types/Dhall.hs +++ b/lib/Internal/Types/Dhall.hs @@ -57,9 +57,7 @@ makeHaskellTypesWith "TxOpts" "TxOpts" "\\(re : Type) -> ((./dhall/Types.dhall).TxOpts_ re).Type" - , SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type" - , SingleConstructor "TransferMatcher" "TransferMatcher" "(./dhall/Types.dhall).TransferMatcher.Type" - , SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer" + , SingleConstructor "TransferMatcher_" "TransferMatcher_" "(./dhall/Types.dhall).TransferMatcher_" , SingleConstructor "Field" "Field" "(./dhall/Types.dhall).Field" , SingleConstructor "Entry" "Entry" "(./dhall/Types.dhall).Entry" , SingleConstructor "PretaxValue" "PretaxValue" "(./dhall/Types.dhall).PretaxValue" @@ -88,11 +86,7 @@ deriveProduct , "CronPat" , "DatePat" , "TaggedAcnt" - , "Budget" , "Income" - , "ShadowTransfer" - , "TransferMatcher" - , "AcntSet" , "DateMatcher" , "ValMatcher" , "YMDMatcher" @@ -200,6 +194,17 @@ data Budget = Budget , bgtShadowTransfers :: [ShadowTransfer] , bgtInterval :: !(Maybe Interval) } + deriving (Generic, Hashable, FromDhall) + +data ShadowTransfer = ShadowTransfer + { stFrom :: TaggedAcnt + , stTo :: TaggedAcnt + , stCurrency :: CurID + , stDesc :: Text + , stMatch :: TransferMatcher_ Text + , stRatio :: Double + } + deriving (Generic, Hashable, FromDhall) deriving instance Hashable PretaxValue @@ -213,8 +218,6 @@ deriving instance Hashable TaxValue deriving instance Hashable PosttaxValue -deriving instance Hashable Budget - deriving instance Hashable TransferValue deriving instance Hashable TransferType @@ -314,11 +317,11 @@ data Transfer a c w v = Transfer } deriving (Eq, Show) -deriving instance Hashable ShadowTransfer +deriving instance Generic (TransferMatcher_ Text) -deriving instance Hashable AcntSet +deriving instance Hashable (TransferMatcher_ Text) -deriving instance Hashable TransferMatcher +deriving instance FromDhall (TransferMatcher_ Text) deriving instance Hashable ValMatcher diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs index cd49a21..d4aa8df 100644 --- a/lib/Internal/Types/Main.hs +++ b/lib/Internal/Types/Main.hs @@ -306,7 +306,7 @@ data AppError | LookupError !LookupSuberr !T.Text | DatePatternError !Natural !Natural !(Maybe Natural) !PatternSuberr | DaySpanError !Gregorian !(Maybe Gregorian) - | StatementError ![TxRecord] ![MatchRe] + | StatementError ![TxRecord] ![StatementParserRe] | PeriodError !Day !Day | LinkError !EntryIndex !EntryIndex | DBError !DBSubError @@ -323,7 +323,9 @@ type AppExceptT = ExceptT AppException type AppExcept = AppExceptT Identity -type MatchRe = StatementParser (T.Text, Regex) +type StatementParserRe = StatementParser (T.Text, Regex) + +type TransferMatcherRe = TransferMatcher_ Regex type TxOptsRe = TxOpts (T.Text, Regex) diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index b492eac..cbdc05b 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -51,6 +51,9 @@ module Internal.Utils , keyVals , realFracToDecimalP , roundToP + , compileRegex + , matchMaybe + , matchGroupsMaybe ) where @@ -69,6 +72,8 @@ import RIO.State import qualified RIO.Text as T import RIO.Time import qualified RIO.Vector as V +import Text.Regex.TDFA hiding (matchAll) +import Text.Regex.TDFA.Text -------------------------------------------------------------------------------- -- intervals @@ -494,7 +499,7 @@ showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} = , ("description", doubleQuote $ unTxDesc e) ] -showMatch :: MatchRe -> T.Text +showMatch :: StatementParserRe -> T.Text showMatch StatementParser {spDate, spVal, spDesc, spOther, spTimes, spPriority} = T.append "Unused match: " $ keyVals [(x, y) | (x, Just y) <- kvs] where @@ -1036,3 +1041,26 @@ realFracToDecimalP p = realFracToDecimal (unPrecision p) roundToP :: Integral i => Precision -> DecimalRaw i -> DecimalRaw i roundToP p = roundTo (unPrecision p) + +compileRegex :: Bool -> T.Text -> AppExcept (Text, Regex) +compileRegex groups pat = case res of + Right re -> return (pat, re) + Left _ -> throwError $ AppException [RegexError pat] + where + res = + compile + (blankCompOpt {newSyntax = True}) + (blankExecOpt {captureGroups = groups}) + pat + +matchMaybe :: T.Text -> Regex -> AppExcept Bool +matchMaybe q re = case execute re q of + Right res -> return $ isJust res + Left _ -> throwError $ AppException [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 _ -> []