ENH use pattern for shadow matcher accounts

dhall/Types.dhall

@@ -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
     fashion)
     -}
-      { Type =
+      \(re : Type) ->
         { 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 :
             {-
             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
+        { tmFrom = None Text
-        , tmTo = AcntSet.default
+        , 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

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)
+    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
-  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
+        fromRes
-          && memberMaybe ta tmTo
+          && 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} =
+      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

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]
+  { mgDate :: ![StatementParserRe]
-  , mgNoDate :: ![MatchRe]
+  , 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

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_"
-  , SingleConstructor "TransferMatcher" "TransferMatcher" "(./dhall/Types.dhall).TransferMatcher.Type"
-  , SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer"
   , 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
 

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)
 

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