ENH use pattern for shadow matcher accounts

This commit is contained in:
Nathan Dwarshuis 2023-08-13 13:29:38 -04:00
parent 3bf6df3b49
commit 4fef3714a2
6 changed files with 120 additions and 111 deletions

View File

@ -984,40 +984,18 @@ let Income =
} }
} }
let AcntSet = let TransferMatcher_ =
{-
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 =
{- {-
Means to match a transfer (which will be used to "clone" it in some Means to match a transfer (which will be used to "clone" it in some
fashion) fashion)
-} -}
{ Type = \(re : Type) ->
{ tmFrom : { tmFrom :
{- {-
List of accounts (which may be empty) to match with the Regex pattern by which matching account ids will be identified
starting account in a transfer.
-} -}
AcntSet.Type Optional re
, tmTo : , tmTo : Optional re
{-
List of accounts (which may be empty) to match with the
ending account in a transfer.
-}
AcntSet.Type
, tmDate : , tmDate :
{- {-
If given, means to match the date of a transfer. If given, means to match the date of a transfer.
@ -1029,9 +1007,12 @@ let TransferMatcher =
-} -}
ValMatcher.Type ValMatcher.Type
} }
let TransferMatcher =
{ Type = TransferMatcher_ Text
, default = , default =
{ tmFrom = AcntSet.default { tmFrom = None Text
, tmTo = AcntSet.default , tmTo = None Text
, tmDate = None DateMatcher , tmDate = None DateMatcher
, tmVal = ValMatcher.default , tmVal = ValMatcher.default
} }
@ -1148,9 +1129,9 @@ in { CurID
, Budget , Budget
, Allocation , Allocation
, Amount , Amount
, TransferMatcher_
, TransferMatcher , TransferMatcher
, ShadowTransfer , ShadowTransfer
, AcntSet
, TaggedAcnt , TaggedAcnt
, AccountTree , AccountTree
, Account , Account

View File

@ -345,26 +345,31 @@ fromShadow
-> ShadowTransfer -> ShadowTransfer
-> m (Maybe ShadowEntrySet) -> m (Maybe ShadowEntrySet)
fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} = 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 () 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 where
curRes = lookupCurrencyKey (CurID stCurrency) curRes = lookupCurrencyKey stCurrency
shaRes = liftExcept $ shadowMatches stMatch tx mRes = liftExcept $ compileMatch stMatch
shadowMatches :: TransferMatcher -> Tx CommitR -> AppExcept Bool shadowMatches :: TransferMatcherRe -> Tx CommitR -> AppExcept Bool
shadowMatches shadowMatches
TransferMatcher {tmFrom, tmTo, tmDate, tmVal} TransferMatcher_ {tmFrom, tmTo, tmDate, tmVal}
Tx {txPrimary, txMeta = TxMeta {txmDate}} = Tx {txPrimary, txMeta = TxMeta {txmDate}} =
do 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 -- NOTE this will only match against the primary entry set since those
-- are what are guaranteed to exist from a transfer -- are what are guaranteed to exist from a transfer
valRes <- case txPrimary of valRes <- case txPrimary of
Left es -> valMatches tmVal $ toRational $ esTotalValue es Left es -> valMatches tmVal $ toRational $ esTotalValue es
Right _ -> return True Right _ -> return True
return $ return $
memberMaybe fa tmFrom fromRes
&& memberMaybe ta tmTo && toRes
&& maybe True (`dateMatches` txmDate) tmDate && maybe True (`dateMatches` txmDate) tmDate
&& valRes && valRes
where where
@ -373,8 +378,18 @@ shadowMatches
getAcntFrom = getAcnt esFrom getAcntFrom = getAcnt esFrom
getAcntTo = getAcnt esTo getAcntTo = getAcnt esTo
getAcnt f = eAcnt . hesPrimary . f getAcnt f = eAcnt . hesPrimary . f
memberMaybe x AcntSet {asList, asInclude} = acntMatches (AcntID a) = maybe (return True) (matchMaybe a)
(if asInclude then id else not) $ x `elem` (AcntID <$> asList)
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 -- random

View File

@ -23,7 +23,6 @@ import qualified RIO.Text as T
import RIO.Time import RIO.Time
import qualified RIO.Vector as V import qualified RIO.Vector as V
import Text.Regex.TDFA hiding (matchAll) import Text.Regex.TDFA hiding (matchAll)
import Text.Regex.TDFA.Text
readHistoryCRUD readHistoryCRUD
:: (MonadUnliftIO m, MonadFinance m) :: (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 d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
return $ Just $ TxRecord d' a e os p 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 matchRecords ms rs = do
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs (matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
case (matched, unmatched, notfound) of case (matched, unmatched, notfound) of
(ms_, [], []) -> return ms_ (ms_, [], []) -> return ms_
(_, us, ns) -> throwError $ AppException [StatementError us ns] (_, us, ns) -> throwError $ AppException [StatementError us ns]
matchPriorities :: [MatchRe] -> [MatchGroup] matchPriorities :: [StatementParserRe] -> [MatchGroup]
matchPriorities = matchPriorities =
fmap matchToGroup fmap matchToGroup
. L.groupBy (\a b -> spPriority a == spPriority b) . L.groupBy (\a b -> spPriority a == spPriority b)
. L.sortOn (Down . spPriority) . L.sortOn (Down . spPriority)
matchToGroup :: [MatchRe] -> MatchGroup matchToGroup :: [StatementParserRe] -> MatchGroup
matchToGroup ms = matchToGroup ms =
uncurry MatchGroup $ uncurry MatchGroup $
first (L.sortOn spDate) $ first (L.sortOn spDate) $
L.partition (isJust . spDate) ms L.partition (isJust . spDate) ms
data MatchGroup = MatchGroup data MatchGroup = MatchGroup
{ mgDate :: ![MatchRe] { mgDate :: ![StatementParserRe]
, mgNoDate :: ![MatchRe] , mgNoDate :: ![StatementParserRe]
} }
deriving (Show) deriving (Show)
@ -184,9 +183,9 @@ zipperSlice f x = go
zipperMatch zipperMatch
:: MonadFinance m :: MonadFinance m
=> Unzipped MatchRe => Unzipped StatementParserRe
-> TxRecord -> TxRecord
-> AppExceptT m (Zipped MatchRe, MatchRes (Tx ())) -> AppExceptT m (Zipped StatementParserRe, MatchRes (Tx ()))
zipperMatch (Unzipped bs cs as) x = go [] cs zipperMatch (Unzipped bs cs as) x = go [] cs
where where
go _ [] = return (Zipped bs $ cs ++ as, MatchFail) go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
@ -201,9 +200,9 @@ zipperMatch (Unzipped bs cs as) x = go [] cs
zipperMatch' zipperMatch'
:: MonadFinance m :: MonadFinance m
=> Zipped MatchRe => Zipped StatementParserRe
-> TxRecord -> TxRecord
-> AppExceptT m (Zipped MatchRe, MatchRes (Tx ())) -> AppExceptT m (Zipped StatementParserRe, MatchRes (Tx ()))
zipperMatch' z x = go z zipperMatch' z x = go z
where where
go (Zipped bs (a : as)) = do go (Zipped bs (a : as)) = do
@ -214,7 +213,7 @@ zipperMatch' z x = go z
return (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass) return (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
go z' = return (z', MatchFail) go z' = return (z', MatchFail)
matchDec :: MatchRe -> Maybe MatchRe matchDec :: StatementParserRe -> Maybe StatementParserRe
matchDec m = case spTimes m of matchDec m = case spTimes m of
Just 1 -> Nothing Just 1 -> Nothing
Just n -> Just $ m {spTimes = Just $ n - 1} Just n -> Just $ m {spTimes = Just $ n - 1}
@ -224,7 +223,7 @@ matchAll
:: MonadFinance m :: MonadFinance m
=> [MatchGroup] => [MatchGroup]
-> [TxRecord] -> [TxRecord]
-> AppExceptT m ([Tx ()], [TxRecord], [MatchRe]) -> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
matchAll = go ([], []) matchAll = go ([], [])
where where
go (matched, unused) gs rs = case (gs, rs) of go (matched, unused) gs rs = case (gs, rs) of
@ -238,7 +237,7 @@ matchGroup
:: MonadFinance m :: MonadFinance m
=> MatchGroup => MatchGroup
-> [TxRecord] -> [TxRecord]
-> AppExceptT m ([Tx ()], [TxRecord], [MatchRe]) -> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
(md, rest, ud) <- matchDates ds rs (md, rest, ud) <- matchDates ds rs
(mn, unmatched, un) <- matchNonDates ns rest (mn, unmatched, un) <- matchNonDates ns rest
@ -246,9 +245,9 @@ matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
matchDates matchDates
:: MonadFinance m :: MonadFinance m
=> [MatchRe] => [StatementParserRe]
-> [TxRecord] -> [TxRecord]
-> AppExceptT m ([Tx ()], [TxRecord], [MatchRe]) -> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
matchDates ms = go ([], [], initZipper ms) matchDates ms = go ([], [], initZipper ms)
where where
go (matched, unmatched, z) [] = go (matched, unmatched, z) [] =
@ -271,9 +270,9 @@ matchDates ms = go ([], [], initZipper ms)
matchNonDates matchNonDates
:: MonadFinance m :: MonadFinance m
=> [MatchRe] => [StatementParserRe]
-> [TxRecord] -> [TxRecord]
-> AppExceptT m ([Tx ()], [TxRecord], [MatchRe]) -> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
matchNonDates ms = go ([], [], initZipper ms) matchNonDates ms = go ([], [], initZipper ms)
where where
go (matched, unmatched, z) [] = go (matched, unmatched, z) [] =
@ -290,7 +289,11 @@ matchNonDates ms = go ([], [], initZipper ms)
MatchFail -> (matched, r : unmatched) MatchFail -> (matched, r : unmatched)
in go (m, u, resetZipper z') rs 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 matches
StatementParser {spTx, spOther, spVal, spDate, spDesc, spPriority} StatementParser {spTx, spOther, spVal, spDate, spDesc, spPriority}
r@TxRecord {trDate, trAmount, trDesc, trOther} = do r@TxRecord {trDate, trAmount, trDesc, trOther} = do
@ -469,7 +472,7 @@ compileOptions o@TxOpts {toAmountFmt = pat} = do
re <- compileRegex True pat re <- compileRegex True pat
return $ o {toAmountFmt = re} return $ o {toAmountFmt = re}
compileMatch :: StatementParser T.Text -> AppExcept MatchRe compileMatch :: StatementParser T.Text -> AppExcept StatementParserRe
compileMatch m@StatementParser {spDesc, spOther} = do compileMatch m@StatementParser {spDesc, spOther} = do
combineError dres ores $ \d os -> m {spDesc = d, spOther = os} combineError dres ores $ \d os -> m {spDesc = d, spOther = os}
where where
@ -477,29 +480,6 @@ compileMatch m@StatementParser {spDesc, spOther} = do
dres = mapM go spDesc dres = mapM go spDesc
ores = combineErrors $ fmap (mapM go) spOther 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 :: MonadFail m => (T.Text, Regex) -> T.Text -> m Decimal
parseDecimal (pat, re) s = case matchGroupsMaybe s re of parseDecimal (pat, re) s = case matchGroupsMaybe s re of
[sign, x, ""] -> Decimal 0 . uncurry (*) <$> readWhole sign x [sign, x, ""] -> Decimal 0 . uncurry (*) <$> readWhole sign x

View File

@ -57,9 +57,7 @@ makeHaskellTypesWith
"TxOpts" "TxOpts"
"TxOpts" "TxOpts"
"\\(re : Type) -> ((./dhall/Types.dhall).TxOpts_ re).Type" "\\(re : Type) -> ((./dhall/Types.dhall).TxOpts_ re).Type"
, SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type" , SingleConstructor "TransferMatcher_" "TransferMatcher_" "(./dhall/Types.dhall).TransferMatcher_"
, SingleConstructor "TransferMatcher" "TransferMatcher" "(./dhall/Types.dhall).TransferMatcher.Type"
, SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer"
, SingleConstructor "Field" "Field" "(./dhall/Types.dhall).Field" , SingleConstructor "Field" "Field" "(./dhall/Types.dhall).Field"
, SingleConstructor "Entry" "Entry" "(./dhall/Types.dhall).Entry" , SingleConstructor "Entry" "Entry" "(./dhall/Types.dhall).Entry"
, SingleConstructor "PretaxValue" "PretaxValue" "(./dhall/Types.dhall).PretaxValue" , SingleConstructor "PretaxValue" "PretaxValue" "(./dhall/Types.dhall).PretaxValue"
@ -88,11 +86,7 @@ deriveProduct
, "CronPat" , "CronPat"
, "DatePat" , "DatePat"
, "TaggedAcnt" , "TaggedAcnt"
, "Budget"
, "Income" , "Income"
, "ShadowTransfer"
, "TransferMatcher"
, "AcntSet"
, "DateMatcher" , "DateMatcher"
, "ValMatcher" , "ValMatcher"
, "YMDMatcher" , "YMDMatcher"
@ -200,6 +194,17 @@ data Budget = Budget
, bgtShadowTransfers :: [ShadowTransfer] , bgtShadowTransfers :: [ShadowTransfer]
, bgtInterval :: !(Maybe Interval) , 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 deriving instance Hashable PretaxValue
@ -213,8 +218,6 @@ deriving instance Hashable TaxValue
deriving instance Hashable PosttaxValue deriving instance Hashable PosttaxValue
deriving instance Hashable Budget
deriving instance Hashable TransferValue deriving instance Hashable TransferValue
deriving instance Hashable TransferType deriving instance Hashable TransferType
@ -314,11 +317,11 @@ data Transfer a c w v = Transfer
} }
deriving (Eq, Show) 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 deriving instance Hashable ValMatcher

View File

@ -306,7 +306,7 @@ data AppError
| LookupError !LookupSuberr !T.Text | LookupError !LookupSuberr !T.Text
| DatePatternError !Natural !Natural !(Maybe Natural) !PatternSuberr | DatePatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
| DaySpanError !Gregorian !(Maybe Gregorian) | DaySpanError !Gregorian !(Maybe Gregorian)
| StatementError ![TxRecord] ![MatchRe] | StatementError ![TxRecord] ![StatementParserRe]
| PeriodError !Day !Day | PeriodError !Day !Day
| LinkError !EntryIndex !EntryIndex | LinkError !EntryIndex !EntryIndex
| DBError !DBSubError | DBError !DBSubError
@ -323,7 +323,9 @@ type AppExceptT = ExceptT AppException
type AppExcept = AppExceptT Identity 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) type TxOptsRe = TxOpts (T.Text, Regex)

View File

@ -51,6 +51,9 @@ module Internal.Utils
, keyVals , keyVals
, realFracToDecimalP , realFracToDecimalP
, roundToP , roundToP
, compileRegex
, matchMaybe
, matchGroupsMaybe
) )
where where
@ -69,6 +72,8 @@ import RIO.State
import qualified RIO.Text as T import qualified RIO.Text as T
import RIO.Time import RIO.Time
import qualified RIO.Vector as V import qualified RIO.Vector as V
import Text.Regex.TDFA hiding (matchAll)
import Text.Regex.TDFA.Text
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- intervals -- intervals
@ -494,7 +499,7 @@ showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} =
, ("description", doubleQuote $ unTxDesc e) , ("description", doubleQuote $ unTxDesc e)
] ]
showMatch :: MatchRe -> T.Text showMatch :: StatementParserRe -> T.Text
showMatch StatementParser {spDate, spVal, spDesc, spOther, spTimes, spPriority} = showMatch StatementParser {spDate, spVal, spDesc, spOther, spTimes, spPriority} =
T.append "Unused match: " $ keyVals [(x, y) | (x, Just y) <- kvs] T.append "Unused match: " $ keyVals [(x, y) | (x, Just y) <- kvs]
where where
@ -1036,3 +1041,26 @@ realFracToDecimalP p = realFracToDecimal (unPrecision p)
roundToP :: Integral i => Precision -> DecimalRaw i -> DecimalRaw i roundToP :: Integral i => Precision -> DecimalRaw i -> DecimalRaw i
roundToP p = roundTo (unPrecision p) 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 _ -> []