ndwarshuis
/
pwncash
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

69
dhall/Types.dhall
View File

@ -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

35
lib/Internal/Budget.hs
View File

@ -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

64
lib/Internal/History.hs
View File

@ -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

27
lib/Internal/Types/Dhall.hs
View File

@ -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

6
lib/Internal/Types/Main.hs
View File

@ -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)

30
lib/Internal/Utils.hs
View File

@ -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 _ -> []