ENH use pattern for shadow matcher accounts
This commit is contained in:
parent
3bf6df3b49
commit
4fef3714a2
|
|
@ -984,40 +984,18 @@ 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 =
|
||||
\(re : Type) ->
|
||||
{ tmFrom :
|
||||
{-
|
||||
List of accounts (which may be empty) to match with the
|
||||
starting account in a transfer.
|
||||
Regex pattern by which matching account ids will be identified
|
||||
-}
|
||||
AcntSet.Type
|
||||
, tmTo :
|
||||
{-
|
||||
List of accounts (which may be empty) to match with the
|
||||
ending account in a transfer.
|
||||
-}
|
||||
AcntSet.Type
|
||||
Optional re
|
||||
, tmTo : Optional re
|
||||
, tmDate :
|
||||
{-
|
||||
If given, means to match the date of a transfer.
|
||||
|
|
@ -1029,9 +1007,12 @@ let TransferMatcher =
|
|||
-}
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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 _ -> []
|
||||
|
|
|
|||
Loading…
Reference in New Issue