diff --git a/hledger-lib/Hledger/Data/Account.hs b/hledger-lib/Hledger/Data/Account.hs index b3da296cf..dba055430 100644 --- a/hledger-lib/Hledger/Data/Account.hs +++ b/hledger-lib/Hledger/Data/Account.hs @@ -14,7 +14,7 @@ import Data.List.Extra (groupSort, groupOn) import Data.Maybe (fromMaybe) import Data.Ord (Down(..)) import qualified Data.Map as M -import Data.Text (pack,unpack) +import qualified Data.Text as T import Safe (headMay, lookupJustDef) import Text.Printf @@ -28,11 +28,12 @@ import Hledger.Utils -- deriving instance Show Account instance Show Account where show Account{..} = printf "Account %s (boring:%s, postings:%d, ebalance:%s, ibalance:%s)" - (pack $ regexReplace ":" "_" $ unpack aname) -- hide : so pretty-show doesn't break line + (T.map colonToUnderscore aname) -- hide : so pretty-show doesn't break line (if aboring then "y" else "n" :: String) anumpostings (showMixedAmount aebalance) (showMixedAmount aibalance) + where colonToUnderscore x = if x == ':' then '_' else x instance Eq Account where (==) a b = aname a == aname b -- quick equality test for speed diff --git a/hledger-lib/Hledger/Data/AccountName.hs b/hledger-lib/Hledger/Data/AccountName.hs index f1da82014..d773905d8 100644 --- a/hledger-lib/Hledger/Data/AccountName.hs +++ b/hledger-lib/Hledger/Data/AccountName.hs @@ -18,7 +18,6 @@ module Hledger.Data.AccountName ( ,accountNameToAccountOnlyRegex ,accountNameToAccountRegex ,accountNameTreeFrom - ,accountRegexToAccountName ,accountSummarisedName ,acctsep ,acctsepchar @@ -48,7 +47,6 @@ import Data.Monoid import Data.Text (Text) import qualified Data.Text as T import Data.Tree -import Text.Printf import Hledger.Data.Types import Hledger.Utils @@ -210,23 +208,17 @@ clipOrEllipsifyAccountName n = clipAccountName n -- | Escape an AccountName for use within a regular expression. -- >>> putStr $ escapeName "First?!#$*?$(*) !@^#*? %)*!@#" -- First\?!#\$\*\?\$\(\*\) !@\^#\*\? %\)\*!@# -escapeName :: AccountName -> Regexp -escapeName = regexReplaceBy "[[?+|()*\\\\^$]" ("\\" <>) +escapeName :: AccountName -> String +escapeName = replaceAllBy (toRegex' "[[?+|()*\\\\^$]") ("\\" <>) -- PARTIAL: should not happen . T.unpack -- | Convert an account name to a regular expression matching it and its subaccounts. accountNameToAccountRegex :: AccountName -> Regexp -accountNameToAccountRegex "" = "" -accountNameToAccountRegex a = printf "^%s(:|$)" (escapeName a) +accountNameToAccountRegex a = toRegex' $ '^' : escapeName a ++ "(:|$)" -- PARTIAL: Is this safe after escapeName? -- | Convert an account name to a regular expression matching it but not its subaccounts. accountNameToAccountOnlyRegex :: AccountName -> Regexp -accountNameToAccountOnlyRegex "" = "" -accountNameToAccountOnlyRegex a = printf "^%s$" $ escapeName a -- XXX pack - --- | Convert an exact account-matching regular expression to a plain account name. -accountRegexToAccountName :: Regexp -> AccountName -accountRegexToAccountName = T.pack . regexReplace "^\\^(.*?)\\(:\\|\\$\\)$" "\\1" -- XXX pack +accountNameToAccountOnlyRegex a = toRegex' $ '^' : escapeName a ++ "$" -- PARTIAL: Is this safe after escapeName? -- -- | Does this string look like an exact account-matching regular expression ? --isAccountRegex :: String -> Bool diff --git a/hledger-lib/Hledger/Data/Journal.hs b/hledger-lib/Hledger/Data/Journal.hs index 8eb8a69ad..61e14d991 100644 --- a/hledger-lib/Hledger/Data/Journal.hs +++ b/hledger-lib/Hledger/Data/Journal.hs @@ -74,7 +74,6 @@ module Hledger.Data.Journal ( journalCashAccountQuery, -- * Misc canonicalStyleFrom, - matchpats, nulljournal, journalCheckBalanceAssertions, journalNumberAndTieTransactions, @@ -301,7 +300,7 @@ journalAccountNameTree = accountNameTreeFrom . journalAccountNames -- or otherwise for accounts with names matched by the case-insensitive -- regular expression @^assets?(:|$)@. journalAssetAccountQuery :: Journal -> Query -journalAssetAccountQuery j = journalAccountTypeQuery [Asset,Cash] "^assets?(:|$)" j +journalAssetAccountQuery = journalAccountTypeQuery [Asset,Cash] (toRegex' "^assets?(:|$)") -- | A query for "Cash" (liquid asset) accounts in this journal, ie accounts -- declared as Cash by account directives, or otherwise with names matched by the @@ -310,43 +309,41 @@ journalAssetAccountQuery j = journalAccountTypeQuery [Asset,Cash] "^assets?(:|$) journalCashAccountQuery :: Journal -> Query journalCashAccountQuery j = case M.lookup Cash (jdeclaredaccounttypes j) of + Nothing -> And [ journalAssetAccountQuery j, Not . Acct $ toRegex' "(investment|receivable|:A/R|:fixed)" ] Just _ -> journalAccountTypeQuery [Cash] notused j where notused = error' "journalCashAccountQuery: this should not have happened!" -- PARTIAL: - Nothing -> And [journalAssetAccountQuery j - ,Not $ Acct "(investment|receivable|:A/R|:fixed)" - ] -- | A query for accounts in this journal which have been -- declared as Liability by account directives, or otherwise for -- accounts with names matched by the case-insensitive regular expression -- @^(debts?|liabilit(y|ies))(:|$)@. journalLiabilityAccountQuery :: Journal -> Query -journalLiabilityAccountQuery = journalAccountTypeQuery [Liability] "^(debts?|liabilit(y|ies))(:|$)" +journalLiabilityAccountQuery = journalAccountTypeQuery [Liability] (toRegex' "^(debts?|liabilit(y|ies))(:|$)") -- | A query for accounts in this journal which have been -- declared as Equity by account directives, or otherwise for -- accounts with names matched by the case-insensitive regular expression -- @^equity(:|$)@. journalEquityAccountQuery :: Journal -> Query -journalEquityAccountQuery = journalAccountTypeQuery [Equity] "^equity(:|$)" +journalEquityAccountQuery = journalAccountTypeQuery [Equity] (toRegex' "^equity(:|$)") -- | A query for accounts in this journal which have been -- declared as Revenue by account directives, or otherwise for -- accounts with names matched by the case-insensitive regular expression -- @^(income|revenue)s?(:|$)@. journalRevenueAccountQuery :: Journal -> Query -journalRevenueAccountQuery = journalAccountTypeQuery [Revenue] "^(income|revenue)s?(:|$)" +journalRevenueAccountQuery = journalAccountTypeQuery [Revenue] (toRegex' "^(income|revenue)s?(:|$)") -- | A query for accounts in this journal which have been -- declared as Expense by account directives, or otherwise for -- accounts with names matched by the case-insensitive regular expression -- @^expenses?(:|$)@. journalExpenseAccountQuery :: Journal -> Query -journalExpenseAccountQuery = journalAccountTypeQuery [Expense] "^expenses?(:|$)" +journalExpenseAccountQuery = journalAccountTypeQuery [Expense] (toRegex' "^expenses?(:|$)") -- | A query for Asset, Liability & Equity accounts in this journal. -- Cf . -journalBalanceSheetAccountQuery :: Journal -> Query +journalBalanceSheetAccountQuery :: Journal -> Query journalBalanceSheetAccountQuery j = Or [journalAssetAccountQuery j ,journalLiabilityAccountQuery j ,journalEquityAccountQuery j @@ -370,17 +367,16 @@ journalAccountTypeQuery :: [AccountType] -> Regexp -> Journal -> Query journalAccountTypeQuery atypes fallbackregex Journal{jdeclaredaccounttypes} = let declaredacctsoftype :: [AccountName] = - concat $ catMaybes [M.lookup t jdeclaredaccounttypes | t <- atypes] + concat $ mapMaybe (`M.lookup` jdeclaredaccounttypes) atypes in case declaredacctsoftype of [] -> Acct fallbackregex - as -> - -- XXX Query isn't able to match account type since that requires extra info from the journal. - -- So we do a hacky search by name instead. - And [ - Or $ map (Acct . accountNameToAccountRegex) as - ,Not $ Or $ map (Acct . accountNameToAccountRegex) differentlytypedsubs - ] + as -> And [ Or acctnameRegexes, Not $ Or differentlyTypedRegexes ] where + -- XXX Query isn't able to match account type since that requires extra info from the journal. + -- So we do a hacky search by name instead. + acctnameRegexes = map (Acct . accountNameToAccountRegex) as + differentlyTypedRegexes = map (Acct . accountNameToAccountRegex) differentlytypedsubs + differentlytypedsubs = concat [subs | (t,bs) <- M.toList jdeclaredaccounttypes , not $ t `elem` atypes @@ -1237,25 +1233,6 @@ postingFindTag tagname p = find ((tagname==) . fst) $ postingAllTags p -- ) -- ] --- Misc helpers - --- | Check if a set of hledger account/description filter patterns matches the --- given account name or entry description. Patterns are case-insensitive --- regular expressions. Prefixed with not:, they become anti-patterns. -matchpats :: [String] -> String -> Bool -matchpats pats str = - (null positives || any match positives) && (null negatives || not (any match negatives)) - where - (negatives,positives) = partition isnegativepat pats - match "" = True - match pat = regexMatchesCI (abspat pat) str - -negateprefix = "not:" - -isnegativepat = (negateprefix `isPrefixOf`) - -abspat pat = if isnegativepat pat then drop (length negateprefix) pat else pat - -- debug helpers -- traceAmountPrecision a = trace (show $ map (precision . acommodity) $ amounts a) a -- tracePostingsCommodities ps = trace (show $ map ((map (precision . acommodity) . amounts) . pamount) ps) ps diff --git a/hledger-lib/Hledger/Data/Ledger.hs b/hledger-lib/Hledger/Data/Ledger.hs index a0c3c7767..4a5969848 100644 --- a/hledger-lib/Hledger/Data/Ledger.hs +++ b/hledger-lib/Hledger/Data/Ledger.hs @@ -17,7 +17,6 @@ module Hledger.Data.Ledger ( ,ledgerRootAccount ,ledgerTopAccounts ,ledgerLeafAccounts - ,ledgerAccountsMatching ,ledgerPostings ,ledgerDateSpan ,ledgerCommodities @@ -26,8 +25,6 @@ module Hledger.Data.Ledger ( where import qualified Data.Map as M --- import Data.Text (Text) -import qualified Data.Text as T import Safe (headDef) import Text.Printf @@ -90,10 +87,6 @@ ledgerTopAccounts = asubs . head . laccounts ledgerLeafAccounts :: Ledger -> [Account] ledgerLeafAccounts = filter (null.asubs) . laccounts --- | Accounts in ledger whose name matches the pattern, in tree order. -ledgerAccountsMatching :: [String] -> Ledger -> [Account] -ledgerAccountsMatching pats = filter (matchpats pats . T.unpack . aname) . laccounts -- XXX pack - -- | List a ledger's postings, in the order parsed. ledgerPostings :: Ledger -> [Posting] ledgerPostings = journalPostings . ljournal diff --git a/hledger-lib/Hledger/Data/Posting.hs b/hledger-lib/Hledger/Data/Posting.hs index f1c96b3e1..64f8a6ec4 100644 --- a/hledger-lib/Hledger/Data/Posting.hs +++ b/hledger-lib/Hledger/Data/Posting.hs @@ -315,7 +315,7 @@ aliasReplace (BasicAlias old new) a Right $ new <> T.drop (T.length old) a | otherwise = Right a aliasReplace (RegexAlias re repl) a = - fmap T.pack $ regexReplaceCIMemo_ re repl $ T.unpack a -- XXX + fmap T.pack $ regexReplaceMemo_ re repl $ T.unpack a -- XXX -- | Apply a specified valuation to this posting's amount, using the -- provided price oracle, commodity styles, reference dates, and diff --git a/hledger-lib/Hledger/Data/Types.hs b/hledger-lib/Hledger/Data/Types.hs index a36ea9dce..d08dacc02 100644 --- a/hledger-lib/Hledger/Data/Types.hs +++ b/hledger-lib/Hledger/Data/Types.hs @@ -166,7 +166,7 @@ data AccountAlias = BasicAlias AccountName AccountName | RegexAlias Regexp Replacement deriving (Eq, Read, Show, Ord, Data, Generic, Typeable) -instance NFData AccountAlias +-- instance NFData AccountAlias data Side = L | R deriving (Eq,Show,Read,Ord,Typeable,Data,Generic) @@ -512,13 +512,13 @@ data Journal = Journal { -- any included journal files. The main file is first, -- followed by any included files in the order encountered. ,jlastreadtime :: ClockTime -- ^ when this journal was last read from its file(s) - } deriving (Eq, Typeable, Data, Generic) + } deriving (Eq, Generic) deriving instance Data ClockTime deriving instance Typeable ClockTime deriving instance Generic ClockTime instance NFData ClockTime -instance NFData Journal +-- instance NFData Journal -- | A journal in the process of being parsed, not yet finalised. -- The data is partial, and list fields are in reverse order. diff --git a/hledger-lib/Hledger/Query.hs b/hledger-lib/Hledger/Query.hs index 3948ba9b5..ca7d52c8d 100644 --- a/hledger-lib/Hledger/Query.hs +++ b/hledger-lib/Hledger/Query.hs @@ -9,8 +9,11 @@ transactions..) by various criteria, and a SimpleTextParser for query expressio -- (may hide other deprecation warnings too). https://github.com/ndmitchell/safe/issues/26 {-# OPTIONS_GHC -Wno-warnings-deprecations #-} -{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, ViewPatterns #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} module Hledger.Query ( -- * Query and QueryOpt @@ -42,20 +45,13 @@ module Hledger.Query ( inAccountQuery, -- * matching matchesTransaction, - matchesTransaction_, matchesPosting, - matchesPosting_, matchesAccount, - matchesAccount_, matchesMixedAmount, matchesAmount, - matchesAmount_, matchesCommodity, - matchesCommodity_, matchesTags, - matchesTags_, matchesPriceDirective, - matchesPriceDirective_, words'', prefixes, -- * tests @@ -63,7 +59,7 @@ module Hledger.Query ( ) where -import Control.Arrow ((>>>)) +import Control.Applicative ((<|>), liftA2, many, optional) import Data.Data import Data.Either import Data.List @@ -74,7 +70,7 @@ import Data.Monoid ((<>)) import qualified Data.Text as T import Data.Time.Calendar import Safe (readDef, readMay, maximumByMay, maximumMay, minimumMay) -import Text.Megaparsec +import Text.Megaparsec (between, noneOf, sepBy) import Text.Megaparsec.Char import Hledger.Utils hiding (words') @@ -111,6 +107,14 @@ data Query = Any -- ^ always match -- matching the regexp if provided, exists deriving (Eq,Data,Typeable) +-- | Construct a payee tag +payeeTag :: Maybe String -> Either RegexError Query +payeeTag = liftA2 Tag (toRegexCI_ "payee") . maybe (pure Nothing) (fmap Just . toRegexCI_) + +-- | Construct a note tag +noteTag :: Maybe String -> Either RegexError Query +noteTag = liftA2 Tag (toRegexCI_ "note") . maybe (pure Nothing) (fmap Just . toRegexCI_) + -- custom Show implementation to show strings more accurately, eg for debugging regexps instance Show Query where show Any = "Any" @@ -273,11 +277,11 @@ parseQueryTerm d (T.stripPrefix "not:" -> Just s) = Right (Left m) -> Right $ Left $ Not m Right (Right _) -> Right $ Left Any -- not:somequeryoption will be ignored Left err -> Left err -parseQueryTerm _ (T.stripPrefix "code:" -> Just s) = Right $ Left $ Code $ T.unpack s -parseQueryTerm _ (T.stripPrefix "desc:" -> Just s) = Right $ Left $ Desc $ T.unpack s -parseQueryTerm _ (T.stripPrefix "payee:" -> Just s) = Right $ Left $ Tag "payee" $ Just $ T.unpack s -parseQueryTerm _ (T.stripPrefix "note:" -> Just s) = Right $ Left $ Tag "note" $ Just $ T.unpack s -parseQueryTerm _ (T.stripPrefix "acct:" -> Just s) = Right $ Left $ Acct $ T.unpack s +parseQueryTerm _ (T.stripPrefix "code:" -> Just s) = Left . Code <$> toRegexCI_ (T.unpack s) +parseQueryTerm _ (T.stripPrefix "desc:" -> Just s) = Left . Desc <$> toRegexCI_ (T.unpack s) +parseQueryTerm _ (T.stripPrefix "payee:" -> Just s) = Left <$> payeeTag (Just $ T.unpack s) +parseQueryTerm _ (T.stripPrefix "note:" -> Just s) = Left <$> noteTag (Just $ T.unpack s) +parseQueryTerm _ (T.stripPrefix "acct:" -> Just s) = Left . Acct <$> toRegexCI_ (T.unpack s) parseQueryTerm d (T.stripPrefix "date2:" -> Just s) = case parsePeriodExpr d s of Left e -> Left $ "\"date2:"++T.unpack s++"\" gave a "++showDateParseError e Right (_,span) -> Right $ Left $ Date2 span @@ -295,8 +299,8 @@ parseQueryTerm _ (T.stripPrefix "depth:" -> Just s) | otherwise = Left "depth: should have a positive number" where n = readDef 0 (T.unpack s) -parseQueryTerm _ (T.stripPrefix "cur:" -> Just s) = Right $ Left $ Sym (T.unpack s) -- support cur: as an alias -parseQueryTerm _ (T.stripPrefix "tag:" -> Just s) = Right $ Left $ Tag n v where (n,v) = parseTag s +parseQueryTerm _ (T.stripPrefix "cur:" -> Just s) = Left . Sym <$> toRegexCI_ ('^' : T.unpack s ++ "$") -- support cur: as an alias +parseQueryTerm _ (T.stripPrefix "tag:" -> Just s) = Left <$> parseTag s parseQueryTerm _ "" = Right $ Left $ Any parseQueryTerm d s = parseQueryTerm d $ defaultprefix<>":"<>s @@ -344,10 +348,12 @@ parseAmountQueryTerm amtarg = parse :: T.Text -> T.Text -> Maybe Quantity parse p s = (T.stripPrefix p . T.strip) s >>= readMay . filter (not.(==' ')) . T.unpack -parseTag :: T.Text -> (Regexp, Maybe Regexp) -parseTag s | "=" `T.isInfixOf` s = (T.unpack n, Just $ tail $ T.unpack v) - | otherwise = (T.unpack s, Nothing) - where (n,v) = T.break (=='=') s +parseTag :: T.Text -> Either RegexError Query +parseTag s = do + tag <- toRegexCI_ . T.unpack $ if T.null v then s else n + body <- if T.null v then pure Nothing else Just <$> toRegexCI_ (tail $ T.unpack v) + return $ Tag tag body + where (n,v) = T.break (=='=') s -- | Parse the value part of a "status:" query, or return an error. parseStatus :: T.Text -> Either String Status @@ -550,8 +556,8 @@ inAccount (QueryOptInAcct a:_) = Just (a,True) -- Just looks at the first query option. inAccountQuery :: [QueryOpt] -> Maybe Query inAccountQuery [] = Nothing -inAccountQuery (QueryOptInAcctOnly a : _) = Just $ Acct $ accountNameToAccountOnlyRegex a -inAccountQuery (QueryOptInAcct a : _) = Just $ Acct $ accountNameToAccountRegex a +inAccountQuery (QueryOptInAcctOnly a : _) = Just . Acct $ accountNameToAccountOnlyRegex a +inAccountQuery (QueryOptInAcct a : _) = Just . Acct $ accountNameToAccountRegex a -- -- | Convert a query to its inverse. -- negateQuery :: Query -> Query @@ -568,36 +574,38 @@ matchesAccount (None) _ = False matchesAccount (Not m) a = not $ matchesAccount m a matchesAccount (Or ms) a = any (`matchesAccount` a) ms matchesAccount (And ms) a = all (`matchesAccount` a) ms -matchesAccount (Acct r) a = regexMatchesCI r (T.unpack a) -- XXX pack +matchesAccount (Acct r) a = match r (T.unpack a) -- XXX pack matchesAccount (Depth d) a = accountNameLevel a <= d matchesAccount (Tag _ _) _ = False matchesAccount _ _ = True -- | Total version of matchesAccount, which will return any error -- arising from a malformed regular expression in the query. -matchesAccount_ :: Query -> AccountName -> Either RegexError Bool -matchesAccount_ (None) _ = Right False -matchesAccount_ (Not m) a = Right $ not $ matchesAccount m a -matchesAccount_ (Or ms) a = sequence (map (`matchesAccount_` a) ms) >>= pure . or -matchesAccount_ (And ms) a = sequence (map (`matchesAccount_` a) ms) >>= pure . and -matchesAccount_ (Acct r) a = regexMatchesCI_ r (T.unpack a) -- XXX pack -matchesAccount_ (Depth d) a = Right $ accountNameLevel a <= d -matchesAccount_ (Tag _ _) _ = Right False -matchesAccount_ _ _ = Right True + -- FIXME: unnecssary +-- matchesAccount_ :: Query -> AccountName -> Either RegexError Bool +-- matchesAccount_ (None) _ = Right False +-- matchesAccount_ (Not m) a = Right $ not $ matchesAccount m a +-- matchesAccount_ (Or ms) a = sequence (map (`matchesAccount_` a) ms) >>= pure . or +-- matchesAccount_ (And ms) a = sequence (map (`matchesAccount_` a) ms) >>= pure . and +-- matchesAccount_ (Acct r) a = match r (T.unpack a) -- XXX pack +-- matchesAccount_ (Depth d) a = Right $ accountNameLevel a <= d +-- matchesAccount_ (Tag _ _) _ = Right False +-- matchesAccount_ _ _ = Right True matchesMixedAmount :: Query -> MixedAmount -> Bool matchesMixedAmount q (Mixed []) = q `matchesAmount` nullamt matchesMixedAmount q (Mixed as) = any (q `matchesAmount`) as matchesCommodity :: Query -> CommoditySymbol -> Bool -matchesCommodity (Sym r) s = regexMatchesCI ("^" ++ r ++ "$") (T.unpack s) -matchesCommodity _ _ = True +matchesCommodity (Sym r) = match r . T.unpack +matchesCommodity _ = const True -- | Total version of matchesCommodity, which will return any error -- arising from a malformed regular expression in the query. -matchesCommodity_ :: Query -> CommoditySymbol -> Either RegexError Bool -matchesCommodity_ (Sym r) s = regexMatchesCI_ ("^" ++ r ++ "$") (T.unpack s) -matchesCommodity_ _ _ = Right True + -- FIXME unnecessary +-- matchesCommodity_ :: Query -> CommoditySymbol -> Bool +-- matchesCommodity_ (Sym r) = match r . T.unpack +-- matchesCommodity_ _ = const True -- | Does the match expression match this (simple) amount ? matchesAmount :: Query -> Amount -> Bool @@ -612,15 +620,16 @@ matchesAmount _ _ = True -- | Total version of matchesAmount, returning any error from a -- malformed regular expression in the query. -matchesAmount_ :: Query -> Amount -> Either RegexError Bool -matchesAmount_ (Not q) a = not <$> q `matchesAmount_` a -matchesAmount_ (Any) _ = Right True -matchesAmount_ (None) _ = Right False -matchesAmount_ (Or qs) a = sequence (map (`matchesAmount_` a) qs) >>= pure . or -matchesAmount_ (And qs) a = sequence (map (`matchesAmount_` a) qs) >>= pure . and -matchesAmount_ (Amt ord n) a = Right $ compareAmount ord n a -matchesAmount_ (Sym r) a = matchesCommodity_ (Sym r) (acommodity a) -matchesAmount_ _ _ = Right True + -- FIXME Unnecessary +-- matchesAmount_ :: Query -> Amount -> Either RegexError Bool +-- matchesAmount_ (Not q) a = not <$> q `matchesAmount_` a +-- matchesAmount_ (Any) _ = Right True +-- matchesAmount_ (None) _ = Right False +-- matchesAmount_ (Or qs) a = sequence (map (`matchesAmount_` a) qs) >>= pure . or +-- matchesAmount_ (And qs) a = sequence (map (`matchesAmount_` a) qs) >>= pure . and +-- matchesAmount_ (Amt ord n) a = Right $ compareAmount ord n a +-- matchesAmount_ (Sym r) a = matchesCommodity_ (Sym r) (acommodity a) +-- matchesAmount_ _ _ = Right True -- | Is this simple (single-amount) mixed amount's quantity less than, greater than, equal to, or unsignedly equal to this number ? -- For multi-amount (multiple commodities, or just unsimplified) mixed amounts this is always true. @@ -647,10 +656,10 @@ matchesPosting (Any) _ = True matchesPosting (None) _ = False matchesPosting (Or qs) p = any (`matchesPosting` p) qs matchesPosting (And qs) p = all (`matchesPosting` p) qs -matchesPosting (Code r) p = regexMatchesCI r $ maybe "" (T.unpack . tcode) $ ptransaction p -matchesPosting (Desc r) p = regexMatchesCI r $ maybe "" (T.unpack . tdescription) $ ptransaction p +matchesPosting (Code r) p = match r $ maybe "" (T.unpack . tcode) $ ptransaction p +matchesPosting (Desc r) p = match r $ maybe "" (T.unpack . tdescription) $ ptransaction p matchesPosting (Acct r) p = matches p || matches (originalPosting p) - where matches p = regexMatchesCI r $ T.unpack $ paccount p -- XXX pack + where matches p = match r . T.unpack $ paccount p -- XXX pack matchesPosting (Date span) p = span `spanContainsDate` postingDate p matchesPosting (Date2 span) p = span `spanContainsDate` postingDate2 p matchesPosting (StatusQ s) p = postingStatus p == s @@ -663,35 +672,36 @@ matchesPosting q@(Amt _ _) Posting{pamount=amt} = q `matchesMixedAmount` amt -- matchesPosting (Empty True) Posting{pamount=a} = mixedAmountLooksZero a matchesPosting (Empty _) _ = True matchesPosting (Sym r) Posting{pamount=Mixed as} = any (matchesCommodity (Sym r)) $ map acommodity as -matchesPosting (Tag n v) p = case (n, v) of - ("payee", Just v) -> maybe False (regexMatchesCI v . T.unpack . transactionPayee) $ ptransaction p - ("note", Just v) -> maybe False (regexMatchesCI v . T.unpack . transactionNote) $ ptransaction p - (n, v) -> matchesTags n v $ postingAllTags p +matchesPosting (Tag n v) p = case (reString n, v) of + ("payee", Just v) -> maybe False (match v . T.unpack . transactionPayee) $ ptransaction p + ("note", Just v) -> maybe False (match v . T.unpack . transactionNote) $ ptransaction p + (_, v) -> matchesTags n v $ postingAllTags p -- | Total version of matchesPosting, returning any error from a -- malformed regular expression in the query. -matchesPosting_ :: Query -> Posting -> Either RegexError Bool -matchesPosting_ (Not q) p = not <$> q `matchesPosting_` p -matchesPosting_ (Any) _ = Right True -matchesPosting_ (None) _ = Right False -matchesPosting_ (Or qs) p = sequence (map (`matchesPosting_` p) qs) >>= pure.or -matchesPosting_ (And qs) p = sequence (map (`matchesPosting_` p) qs) >>= pure.and -matchesPosting_ (Code r) p = regexMatchesCI_ r $ maybe "" (T.unpack . tcode) $ ptransaction p -matchesPosting_ (Desc r) p = regexMatchesCI_ r $ maybe "" (T.unpack . tdescription) $ ptransaction p -matchesPosting_ (Acct r) p = sequence [matches p, matches (originalPosting p)] >>= pure.or - where matches p = regexMatchesCI_ r $ T.unpack $ paccount p -- XXX pack -matchesPosting_ (Date span) p = Right $ span `spanContainsDate` postingDate p -matchesPosting_ (Date2 span) p = Right $ span `spanContainsDate` postingDate2 p -matchesPosting_ (StatusQ s) p = Right $ postingStatus p == s -matchesPosting_ (Real v) p = Right $ v == isReal p -matchesPosting_ q@(Depth _) Posting{paccount=a} = q `matchesAccount_` a -matchesPosting_ q@(Amt _ _) Posting{pamount=amt} = Right $ q `matchesMixedAmount` amt -matchesPosting_ (Empty _) _ = Right True -matchesPosting_ (Sym r) Posting{pamount=Mixed as} = sequence (map (matchesCommodity_ (Sym r)) $ map acommodity as) >>= pure.or -matchesPosting_ (Tag n v) p = case (n, v) of - ("payee", Just v) -> maybe (Right False) (T.unpack . transactionPayee >>> regexMatchesCI_ v) $ ptransaction p - ("note", Just v) -> maybe (Right False) (T.unpack . transactionNote >>> regexMatchesCI_ v) $ ptransaction p - (n, v) -> matchesTags_ n v $ postingAllTags p + -- -- FIXME: unnecessary +-- matchesPosting_ :: Query -> Posting -> Bool +-- matchesPosting_ (Not q) p = not <$> q `matchesPosting_` p +-- matchesPosting_ (Any) _ = Right True +-- matchesPosting_ (None) _ = Right False +-- matchesPosting_ (Or qs) p = sequence (map (`matchesPosting_` p) qs) >>= pure.or +-- matchesPosting_ (And qs) p = sequence (map (`matchesPosting_` p) qs) >>= pure.and +-- matchesPosting_ (Code r) p = match r $ maybe "" (T.unpack . tcode) $ ptransaction p +-- matchesPosting_ (Desc r) p = match r $ maybe "" (T.unpack . tdescription) $ ptransaction p +-- matchesPosting_ (Acct r) p = sequence [matches p, matches (originalPosting p)] >>= pure.or +-- where matches p = match r $ T.unpack $ paccount p -- XXX pack +-- matchesPosting_ (Date span) p = Right $ span `spanContainsDate` postingDate p +-- matchesPosting_ (Date2 span) p = Right $ span `spanContainsDate` postingDate2 p +-- matchesPosting_ (StatusQ s) p = Right $ postingStatus p == s +-- matchesPosting_ (Real v) p = Right $ v == isReal p +-- matchesPosting_ q@(Depth _) Posting{paccount=a} = q `matchesAccount_` a +-- matchesPosting_ q@(Amt _ _) Posting{pamount=amt} = Right $ q `matchesMixedAmount` amt +-- matchesPosting_ (Empty _) _ = Right True +-- matchesPosting_ (Sym r) Posting{pamount=Mixed as} = sequence (map (matchesCommodity_ (Sym r)) $ map acommodity as) >>= pure.or +-- matchesPosting_ (Tag n v) p = case (n, v) of +-- ("payee", Just v) -> maybe (Right False) (T.unpack . transactionPayee >>> match v) $ ptransaction p +-- ("note", Just v) -> maybe (Right False) (T.unpack . transactionNote >>> match v) $ ptransaction p +-- (n, v) -> matchesTags_ n v $ postingAllTags p -- | Does the match expression match this transaction ? matchesTransaction :: Query -> Transaction -> Bool @@ -700,8 +710,8 @@ matchesTransaction (Any) _ = True matchesTransaction (None) _ = False matchesTransaction (Or qs) t = any (`matchesTransaction` t) qs matchesTransaction (And qs) t = all (`matchesTransaction` t) qs -matchesTransaction (Code r) t = regexMatchesCI r $ T.unpack $ tcode t -matchesTransaction (Desc r) t = regexMatchesCI r $ T.unpack $ tdescription t +matchesTransaction (Code r) t = match r $ T.unpack $ tcode t +matchesTransaction (Desc r) t = match r $ T.unpack $ tdescription t matchesTransaction q@(Acct _) t = any (q `matchesPosting`) $ tpostings t matchesTransaction (Date span) t = spanContainsDate span $ tdate t matchesTransaction (Date2 span) t = spanContainsDate span $ transactionDate2 t @@ -711,51 +721,41 @@ matchesTransaction q@(Amt _ _) t = any (q `matchesPosting`) $ tpostings t matchesTransaction (Empty _) _ = True matchesTransaction (Depth d) t = any (Depth d `matchesPosting`) $ tpostings t matchesTransaction q@(Sym _) t = any (q `matchesPosting`) $ tpostings t -matchesTransaction (Tag n v) t = case (n, v) of - ("payee", Just v) -> regexMatchesCI v . T.unpack . transactionPayee $ t - ("note", Just v) -> regexMatchesCI v . T.unpack . transactionNote $ t - (n, v) -> matchesTags n v $ transactionAllTags t +matchesTransaction (Tag n v) t = case (reString n, v) of + ("payee", Just v) -> match v . T.unpack . transactionPayee $ t + ("note", Just v) -> match v . T.unpack . transactionNote $ t + (_, v) -> matchesTags n v $ transactionAllTags t -- | Total version of matchesTransaction, returning any error from a -- malformed regular expression in the query. -matchesTransaction_ :: Query -> Transaction -> Either RegexError Bool -matchesTransaction_ (Not q) t = not <$> q `matchesTransaction_` t -matchesTransaction_ (Any) _ = Right True -matchesTransaction_ (None) _ = Right False -matchesTransaction_ (Or qs) t = sequence (map (`matchesTransaction_` t) qs) >>= pure.or -matchesTransaction_ (And qs) t = sequence (map (`matchesTransaction_` t) qs) >>= pure.and -matchesTransaction_ (Code r) t = regexMatchesCI_ r $ T.unpack $ tcode t -matchesTransaction_ (Desc r) t = regexMatchesCI_ r $ T.unpack $ tdescription t -matchesTransaction_ q@(Acct _) t = sequence (map (q `matchesPosting_`) $ tpostings t) >>= pure.or -matchesTransaction_ (Date span) t = Right $ spanContainsDate span $ tdate t -matchesTransaction_ (Date2 span) t = Right $ spanContainsDate span $ transactionDate2 t -matchesTransaction_ (StatusQ s) t = Right $ tstatus t == s -matchesTransaction_ (Real v) t = Right $ v == hasRealPostings t -matchesTransaction_ q@(Amt _ _) t = sequence (map (q `matchesPosting_`) $ tpostings t) >>= pure.or -matchesTransaction_ (Empty _) _ = Right True -matchesTransaction_ (Depth d) t = sequence (map (Depth d `matchesPosting_`) $ tpostings t) >>= pure.or -matchesTransaction_ q@(Sym _) t = sequence (map (q `matchesPosting_`) $ tpostings t) >>= pure.or -matchesTransaction_ (Tag n v) t = case (n, v) of - ("payee", Just v) -> regexMatchesCI_ v . T.unpack . transactionPayee $ t - ("note", Just v) -> regexMatchesCI_ v . T.unpack . transactionNote $ t - (n, v) -> matchesTags_ n v $ transactionAllTags t + -- FIXME: unnecessary +-- matchesTransaction_ :: Query -> Transaction -> Either RegexError Bool +-- matchesTransaction_ (Not q) t = not <$> q `matchesTransaction_` t +-- matchesTransaction_ (Any) _ = Right True +-- matchesTransaction_ (None) _ = Right False +-- matchesTransaction_ (Or qs) t = sequence (map (`matchesTransaction_` t) qs) >>= pure.or +-- matchesTransaction_ (And qs) t = sequence (map (`matchesTransaction_` t) qs) >>= pure.and +-- matchesTransaction_ (Code r) t = match r $ T.unpack $ tcode t +-- matchesTransaction_ (Desc r) t = match r $ T.unpack $ tdescription t +-- matchesTransaction_ q@(Acct _) t = sequence (map (q `matchesPosting_`) $ tpostings t) >>= pure.or +-- matchesTransaction_ (Date span) t = Right $ spanContainsDate span $ tdate t +-- matchesTransaction_ (Date2 span) t = Right $ spanContainsDate span $ transactionDate2 t +-- matchesTransaction_ (StatusQ s) t = Right $ tstatus t == s +-- matchesTransaction_ (Real v) t = Right $ v == hasRealPostings t +-- matchesTransaction_ q@(Amt _ _) t = sequence (map (q `matchesPosting_`) $ tpostings t) >>= pure.or +-- matchesTransaction_ (Empty _) _ = Right True +-- matchesTransaction_ (Depth d) t = sequence (map (Depth d `matchesPosting_`) $ tpostings t) >>= pure.or +-- matchesTransaction_ q@(Sym _) t = sequence (map (q `matchesPosting_`) $ tpostings t) >>= pure.or +-- matchesTransaction_ (Tag n v) t = case (n, v) of +-- ("payee", Just v) -> match v . T.unpack . transactionPayee $ t +-- ("note", Just v) -> match v . T.unpack . transactionNote $ t +-- (n, v) -> matchesTags_ n v $ transactionAllTags t -- | Does the query match the name and optionally the value of any of these tags ? matchesTags :: Regexp -> Maybe Regexp -> [Tag] -> Bool -matchesTags namepat valuepat = not . null . filter (match namepat valuepat) +matchesTags namepat valuepat = not . null . filter (matches namepat valuepat) where - match npat Nothing (n,_) = regexMatchesCI npat (T.unpack n) -- XXX - match npat (Just vpat) (n,v) = regexMatchesCI npat (T.unpack n) && regexMatchesCI vpat (T.unpack v) - --- | Total version of matchesTags, returning any error from a --- malformed regular expression in the query. -matchesTags_ :: Regexp -> Maybe Regexp -> [Tag] -> Either RegexError Bool -matchesTags_ namepat valuepat tags = - sequence (map (match namepat valuepat) tags) >>= pure.or - where - match npat Nothing (n,_) = regexMatchesCI_ npat (T.unpack n) -- XXX - match npat (Just vpat) (n,v) = - sequence [regexMatchesCI_ npat (T.unpack n), regexMatchesCI_ vpat (T.unpack v)] >>= pure.and + matches npat vpat (n,v) = match npat (T.unpack n) && maybe (const True) match vpat (T.unpack v) -- | Does the query match this market price ? matchesPriceDirective :: Query -> PriceDirective -> Bool @@ -770,38 +770,39 @@ matchesPriceDirective _ _ = True -- | Total version of matchesPriceDirective, returning any error from -- a malformed regular expression in the query. -matchesPriceDirective_ :: Query -> PriceDirective -> Either RegexError Bool -matchesPriceDirective_ (None) _ = Right False -matchesPriceDirective_ (Not q) p = not <$> matchesPriceDirective_ q p -matchesPriceDirective_ (Or qs) p = sequence (map (`matchesPriceDirective_` p) qs) >>= pure.or -matchesPriceDirective_ (And qs) p = sequence (map (`matchesPriceDirective_` p) qs) >>= pure.and -matchesPriceDirective_ q@(Amt _ _) p = matchesAmount_ q (pdamount p) -matchesPriceDirective_ q@(Sym _) p = matchesCommodity_ q (pdcommodity p) -matchesPriceDirective_ (Date span) p = Right $ spanContainsDate span (pddate p) -matchesPriceDirective_ _ _ = Right True + -- FIXME unnecessary +-- matchesPriceDirective_ :: Query -> PriceDirective -> Either RegexError Bool +-- matchesPriceDirective_ (None) _ = Right False +-- matchesPriceDirective_ (Not q) p = not <$> matchesPriceDirective_ q p +-- matchesPriceDirective_ (Or qs) p = sequence (map (`matchesPriceDirective_` p) qs) >>= pure.or +-- matchesPriceDirective_ (And qs) p = sequence (map (`matchesPriceDirective_` p) qs) >>= pure.and +-- matchesPriceDirective_ q@(Amt _ _) p = matchesAmount_ q (pdamount p) +-- matchesPriceDirective_ q@(Sym _) p = matchesCommodity_ q (pdcommodity p) +-- matchesPriceDirective_ (Date span) p = Right $ spanContainsDate span (pddate p) +-- matchesPriceDirective_ _ _ = Right True -- tests tests_Query = tests "Query" [ test "simplifyQuery" $ do - (simplifyQuery $ Or [Acct "a"]) @?= (Acct "a") + (simplifyQuery $ Or [Acct $ toRegex' "a"]) @?= (Acct $ toRegex' "a") (simplifyQuery $ Or [Any,None]) @?= (Any) (simplifyQuery $ And [Any,None]) @?= (None) (simplifyQuery $ And [Any,Any]) @?= (Any) - (simplifyQuery $ And [Acct "b",Any]) @?= (Acct "b") + (simplifyQuery $ And [Acct $ toRegex' "b",Any]) @?= (Acct $ toRegex' "b") (simplifyQuery $ And [Any,And [Date (DateSpan Nothing Nothing)]]) @?= (Any) (simplifyQuery $ And [Date (DateSpan Nothing (Just $ fromGregorian 2013 01 01)), Date (DateSpan (Just $ fromGregorian 2012 01 01) Nothing)]) @?= (Date (DateSpan (Just $ fromGregorian 2012 01 01) (Just $ fromGregorian 2013 01 01))) - (simplifyQuery $ And [Or [],Or [Desc "b b"]]) @?= (Desc "b b") + (simplifyQuery $ And [Or [],Or [Desc $ toRegex' "b b"]]) @?= (Desc $ toRegex' "b b") ,test "parseQuery" $ do - (parseQuery nulldate "acct:'expenses:autres d\233penses' desc:b") @?= Right (And [Acct "expenses:autres d\233penses", Desc "b"], []) - parseQuery nulldate "inacct:a desc:\"b b\"" @?= Right (Desc "b b", [QueryOptInAcct "a"]) + (parseQuery nulldate "acct:'expenses:autres d\233penses' desc:b") @?= Right (And [Acct $ toRegexCI' "expenses:autres d\233penses", Desc $ toRegexCI' "b"], []) + parseQuery nulldate "inacct:a desc:\"b b\"" @?= Right (Desc $ toRegexCI' "b b", [QueryOptInAcct "a"]) parseQuery nulldate "inacct:a inacct:b" @?= Right (Any, [QueryOptInAcct "a", QueryOptInAcct "b"]) - parseQuery nulldate "desc:'x x'" @?= Right (Desc "x x", []) - parseQuery nulldate "'a a' 'b" @?= Right (Or [Acct "a a",Acct "'b"], []) - parseQuery nulldate "\"" @?= Right (Acct "\"", []) + parseQuery nulldate "desc:'x x'" @?= Right (Desc $ toRegexCI' "x x", []) + parseQuery nulldate "'a a' 'b" @?= Right (Or [Acct $ toRegexCI' "a a",Acct $ toRegexCI' "'b"], []) + parseQuery nulldate "\"" @?= Right (Acct $ toRegexCI' "\"", []) ,test "words''" $ do (words'' [] "a b") @?= ["a","b"] @@ -820,23 +821,23 @@ tests_Query = tests "Query" [ filterQuery queryIsDepth (And [Date nulldatespan, Not (Or [Any, Depth 1])]) @?= Any -- XXX unclear ,test "parseQueryTerm" $ do - parseQueryTerm nulldate "a" @?= Right (Left $ Acct "a") - parseQueryTerm nulldate "acct:expenses:autres d\233penses" @?= Right (Left $ Acct "expenses:autres d\233penses") - parseQueryTerm nulldate "not:desc:a b" @?= Right (Left $ Not $ Desc "a b") + parseQueryTerm nulldate "a" @?= Right (Left $ Acct $ toRegexCI' "a") + parseQueryTerm nulldate "acct:expenses:autres d\233penses" @?= Right (Left $ Acct $ toRegexCI' "expenses:autres d\233penses") + parseQueryTerm nulldate "not:desc:a b" @?= Right (Left $ Not $ Desc $ toRegexCI' "a b") parseQueryTerm nulldate "status:1" @?= Right (Left $ StatusQ Cleared) parseQueryTerm nulldate "status:*" @?= Right (Left $ StatusQ Cleared) parseQueryTerm nulldate "status:!" @?= Right (Left $ StatusQ Pending) parseQueryTerm nulldate "status:0" @?= Right (Left $ StatusQ Unmarked) parseQueryTerm nulldate "status:" @?= Right (Left $ StatusQ Unmarked) - parseQueryTerm nulldate "payee:x" @?= Right (Left $ Tag "payee" (Just "x")) - parseQueryTerm nulldate "note:x" @?= Right (Left $ Tag "note" (Just "x")) + parseQueryTerm nulldate "payee:x" @?= Left <$> payeeTag (Just "x") + parseQueryTerm nulldate "note:x" @?= Left <$> noteTag (Just "x") parseQueryTerm nulldate "real:1" @?= Right (Left $ Real True) parseQueryTerm nulldate "date:2008" @?= Right (Left $ Date $ DateSpan (Just $ fromGregorian 2008 01 01) (Just $ fromGregorian 2009 01 01)) parseQueryTerm nulldate "date:from 2012/5/17" @?= Right (Left $ Date $ DateSpan (Just $ fromGregorian 2012 05 17) Nothing) parseQueryTerm nulldate "date:20180101-201804" @?= Right (Left $ Date $ DateSpan (Just $ fromGregorian 2018 01 01) (Just $ fromGregorian 2018 04 01)) parseQueryTerm nulldate "inacct:a" @?= Right (Right $ QueryOptInAcct "a") - parseQueryTerm nulldate "tag:a" @?= Right (Left $ Tag "a" Nothing) - parseQueryTerm nulldate "tag:a=some value" @?= Right (Left $ Tag "a" (Just "some value")) + parseQueryTerm nulldate "tag:a" @?= Right (Left $ Tag (toRegexCI' "a") Nothing) + parseQueryTerm nulldate "tag:a=some value" @?= Right (Left $ Tag (toRegexCI' "a") (Just $ toRegexCI' "some value")) parseQueryTerm nulldate "amt:<0" @?= Right (Left $ Amt Lt 0) parseQueryTerm nulldate "amt:>10000.10" @?= Right (Left $ Amt AbsGt 10000.1) @@ -869,14 +870,14 @@ tests_Query = tests "Query" [ queryEndDate False (Or [Date $ DateSpan Nothing small, Date $ DateSpan Nothing Nothing]) @?= Nothing ,test "matchesAccount" $ do - assertBool "" $ (Acct "b:c") `matchesAccount` "a:bb:c:d" - assertBool "" $ not $ (Acct "^a:b") `matchesAccount` "c:a:b" + assertBool "" $ (Acct $ toRegex' "b:c") `matchesAccount` "a:bb:c:d" + assertBool "" $ not $ (Acct $ toRegex' "^a:b") `matchesAccount` "c:a:b" assertBool "" $ Depth 2 `matchesAccount` "a" assertBool "" $ Depth 2 `matchesAccount` "a:b" assertBool "" $ not $ Depth 2 `matchesAccount` "a:b:c" assertBool "" $ Date nulldatespan `matchesAccount` "a" assertBool "" $ Date2 nulldatespan `matchesAccount` "a" - assertBool "" $ not $ (Tag "a" Nothing) `matchesAccount` "a" + assertBool "" $ not $ Tag (toRegex' "a") Nothing `matchesAccount` "a" ,tests "matchesPosting" [ test "positive match on cleared posting status" $ @@ -892,32 +893,33 @@ tests_Query = tests "Query" [ ,test "real:1 on real posting" $ assertBool "" $ (Real True) `matchesPosting` nullposting{ptype=RegularPosting} ,test "real:1 on virtual posting fails" $ assertBool "" $ not $ (Real True) `matchesPosting` nullposting{ptype=VirtualPosting} ,test "real:1 on balanced virtual posting fails" $ assertBool "" $ not $ (Real True) `matchesPosting` nullposting{ptype=BalancedVirtualPosting} - ,test "acct:" $ assertBool "" $ (Acct "'b") `matchesPosting` nullposting{paccount="'b"} + ,test "acct:" $ assertBool "" $ (Acct $ toRegex' "'b") `matchesPosting` nullposting{paccount="'b"} ,test "tag:" $ do - assertBool "" $ not $ (Tag "a" (Just "r$")) `matchesPosting` nullposting - assertBool "" $ (Tag "foo" Nothing) `matchesPosting` nullposting{ptags=[("foo","")]} - assertBool "" $ (Tag "foo" Nothing) `matchesPosting` nullposting{ptags=[("foo","baz")]} - assertBool "" $ (Tag "foo" (Just "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]} - assertBool "" $ not $ (Tag "foo" (Just "a$")) `matchesPosting` nullposting{ptags=[("foo","bar")]} - assertBool "" $ not $ (Tag " foo " (Just "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]} - assertBool "" $ not $ (Tag "foo foo" (Just " ar ba ")) `matchesPosting` nullposting{ptags=[("foo foo","bar bar")]} - ,test "a tag match on a posting also sees inherited tags" $ assertBool "" $ (Tag "txntag" Nothing) `matchesPosting` nullposting{ptransaction=Just nulltransaction{ttags=[("txntag","")]}} + assertBool "" $ not $ (Tag (toRegex' "a") (Just $ toRegex' "r$")) `matchesPosting` nullposting + assertBool "" $ (Tag (toRegex' "foo") Nothing) `matchesPosting` nullposting{ptags=[("foo","")]} + assertBool "" $ (Tag (toRegex' "foo") Nothing) `matchesPosting` nullposting{ptags=[("foo","baz")]} + assertBool "" $ (Tag (toRegex' "foo") (Just $ toRegex' "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]} + assertBool "" $ not $ (Tag (toRegex' "foo") (Just $ toRegex' "a$")) `matchesPosting` nullposting{ptags=[("foo","bar")]} + assertBool "" $ not $ (Tag (toRegex' " foo ") (Just $ toRegex' "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]} + assertBool "" $ not $ (Tag (toRegex' "foo foo") (Just $ toRegex' " ar ba ")) `matchesPosting` nullposting{ptags=[("foo foo","bar bar")]} + ,test "a tag match on a posting also sees inherited tags" $ assertBool "" $ (Tag (toRegex' "txntag") Nothing) `matchesPosting` nullposting{ptransaction=Just nulltransaction{ttags=[("txntag","")]}} ,test "cur:" $ do - assertBool "" $ not $ (Sym "$") `matchesPosting` nullposting{pamount=Mixed [usd 1]} -- becomes "^$$", ie testing for null symbol - assertBool "" $ (Sym "\\$") `matchesPosting` nullposting{pamount=Mixed [usd 1]} -- have to quote $ for regexpr - assertBool "" $ (Sym "shekels") `matchesPosting` nullposting{pamount=Mixed [nullamt{acommodity="shekels"}]} - assertBool "" $ not $ (Sym "shek") `matchesPosting` nullposting{pamount=Mixed [nullamt{acommodity="shekels"}]} + let toSym = either id (const $ error' "No query opts") . either error' id . parseQueryTerm (fromGregorian 2000 01 01) . ("cur:"<>) + assertBool "" $ not $ toSym "$" `matchesPosting` nullposting{pamount=Mixed [usd 1]} -- becomes "^$$", ie testing for null symbol + assertBool "" $ (toSym "\\$") `matchesPosting` nullposting{pamount=Mixed [usd 1]} -- have to quote $ for regexpr + assertBool "" $ (toSym "shekels") `matchesPosting` nullposting{pamount=Mixed [nullamt{acommodity="shekels"}]} + assertBool "" $ not $ (toSym "shek") `matchesPosting` nullposting{pamount=Mixed [nullamt{acommodity="shekels"}]} ] ,test "matchesTransaction" $ do assertBool "" $ Any `matchesTransaction` nulltransaction - assertBool "" $ not $ (Desc "x x") `matchesTransaction` nulltransaction{tdescription="x"} - assertBool "" $ (Desc "x x") `matchesTransaction` nulltransaction{tdescription="x x"} + assertBool "" $ not $ (Desc $ toRegex' "x x") `matchesTransaction` nulltransaction{tdescription="x"} + assertBool "" $ (Desc $ toRegex' "x x") `matchesTransaction` nulltransaction{tdescription="x x"} -- see posting for more tag tests - assertBool "" $ (Tag "foo" (Just "a")) `matchesTransaction` nulltransaction{ttags=[("foo","bar")]} - assertBool "" $ (Tag "payee" (Just "payee")) `matchesTransaction` nulltransaction{tdescription="payee|note"} - assertBool "" $ (Tag "note" (Just "note")) `matchesTransaction` nulltransaction{tdescription="payee|note"} + assertBool "" $ (Tag (toRegex' "foo") (Just $ toRegex' "a")) `matchesTransaction` nulltransaction{ttags=[("foo","bar")]} + assertBool "" $ (Tag (toRegex' "payee") (Just $ toRegex' "payee")) `matchesTransaction` nulltransaction{tdescription="payee|note"} + assertBool "" $ (Tag (toRegex' "note") (Just $ toRegex' "note")) `matchesTransaction` nulltransaction{tdescription="payee|note"} -- a tag match on a transaction also matches posting tags - assertBool "" $ (Tag "postingtag" Nothing) `matchesTransaction` nulltransaction{tpostings=[nullposting{ptags=[("postingtag","")]}]} + assertBool "" $ (Tag (toRegex' "postingtag") Nothing) `matchesTransaction` nulltransaction{tpostings=[nullposting{ptags=[("postingtag","")]}]} ] diff --git a/hledger-lib/Hledger/Read/Common.hs b/hledger-lib/Hledger/Read/Common.hs index 286fabb00..7e10af874 100644 --- a/hledger-lib/Hledger/Read/Common.hs +++ b/hledger-lib/Hledger/Read/Common.hs @@ -144,7 +144,7 @@ import Text.Megaparsec.Custom import Control.Applicative.Permutations import Hledger.Data -import Hledger.Utils +import Hledger.Utils hiding (match) --- ** doctest setup -- $setup diff --git a/hledger-lib/Hledger/Read/CsvReader.hs b/hledger-lib/Hledger/Read/CsvReader.hs index 298a315ce..450c00f25 100644 --- a/hledger-lib/Hledger/Read/CsvReader.hs +++ b/hledger-lib/Hledger/Read/CsvReader.hs @@ -44,6 +44,7 @@ import "base-compat-batteries" Prelude.Compat hiding (fail) import Control.Exception (IOException, handle, throw) import Control.Monad (liftM, unless, when) import Control.Monad.Except (ExceptT, throwError) +import qualified Control.Monad.Fail as Fail import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.State.Strict (StateT, get, modify', evalStateT) import Control.Monad.Trans.Class (lift) @@ -69,7 +70,7 @@ import qualified Data.Csv.Parser.Megaparsec as CassavaMP import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.Foldable -import Text.Megaparsec hiding (parse) +import Text.Megaparsec hiding (match, parse) import Text.Megaparsec.Char import Text.Megaparsec.Custom import Text.Printf (printf) @@ -294,17 +295,14 @@ type FieldTemplate = String -- | A strptime date parsing pattern, as supported by Data.Time.Format. type DateFormat = String --- | A regular expression. -type RegexpPattern = String - -- | A prefix for a matcher test, either & or none (implicit or). data MatcherPrefix = And | None deriving (Show, Eq) -- | A single test for matching a CSV record, in one way or another. data Matcher = - RecordMatcher MatcherPrefix RegexpPattern -- ^ match if this regexp matches the overall CSV record - | FieldMatcher MatcherPrefix CsvFieldReference RegexpPattern -- ^ match if this regexp matches the referenced CSV field's value + RecordMatcher MatcherPrefix Regexp -- ^ match if this regexp matches the overall CSV record + | FieldMatcher MatcherPrefix CsvFieldReference Regexp -- ^ match if this regexp matches the referenced CSV field's value deriving (Show, Eq) -- | A conditional block: a set of CSV record matchers, and a sequence @@ -617,9 +615,9 @@ recordmatcherp end = do -- _ <- optional (matchoperatorp >> lift skipNonNewlineSpaces >> optional newline) p <- matcherprefixp r <- regexp end + return $ RecordMatcher p r -- when (null ps) $ -- Fail.fail "start of record matcher found, but no patterns afterward\n(patterns should not be indented)\n" - return $ RecordMatcher p r "record matcher" -- | A single matcher for a specific field. A csv field reference @@ -656,13 +654,15 @@ csvfieldreferencep = do return $ '%' : quoteIfNeeded f -- A single regular expression -regexp :: CsvRulesParser () -> CsvRulesParser RegexpPattern +regexp :: CsvRulesParser () -> CsvRulesParser Regexp regexp end = do lift $ dbgparse 8 "trying regexp" -- notFollowedBy matchoperatorp c <- lift nonspace cs <- anySingle `manyTill` end - return $ strip $ c:cs + case toRegexCI_ . strip $ c:cs of + Left x -> Fail.fail $ "CSV parser: " ++ x + Right x -> return x -- -- A match operator, indicating the type of match to perform. -- -- Currently just ~ meaning case insensitive infix regex match. @@ -1181,7 +1181,7 @@ getEffectiveAssignment rules record f = lastMay $ map snd $ assignments where -- does this individual matcher match the current csv record ? matcherMatches :: Matcher -> Bool - matcherMatches (RecordMatcher _ pat) = regexMatchesCI pat' wholecsvline + matcherMatches (RecordMatcher _ pat) = match pat' wholecsvline where pat' = dbg7 "regex" pat -- A synthetic whole CSV record to match against. Note, this can be @@ -1191,7 +1191,7 @@ getEffectiveAssignment rules record f = lastMay $ map snd $ assignments -- - and the field separator is always comma -- which means that a field containing a comma will look like two fields. wholecsvline = dbg7 "wholecsvline" $ intercalate "," record - matcherMatches (FieldMatcher _ csvfieldref pat) = regexMatchesCI pat csvfieldvalue + matcherMatches (FieldMatcher _ csvfieldref pat) = match pat csvfieldvalue where -- the value of the referenced CSV field to match against. csvfieldvalue = dbg7 "csvfieldvalue" $ replaceCsvFieldReference rules record csvfieldref @@ -1199,7 +1199,7 @@ getEffectiveAssignment rules record f = lastMay $ map snd $ assignments -- | Render a field assignment's template, possibly interpolating referenced -- CSV field values. Outer whitespace is removed from interpolated values. renderTemplate :: CsvRules -> CsvRecord -> FieldTemplate -> String -renderTemplate rules record t = regexReplaceBy "%[A-z0-9_-]+" (replaceCsvFieldReference rules record) t +renderTemplate rules record t = replaceAllBy (toRegex' "%[A-z0-9_-]+") (replaceCsvFieldReference rules record) t -- PARTIAL: should not happen -- | Replace something that looks like a reference to a csv field ("%date" or "%1) -- with that field's value. If it doesn't look like a field reference, or if we @@ -1256,12 +1256,12 @@ tests_CsvReader = tests "CsvReader" [ ,test "assignment with empty value" $ parseWithState' defrules rulesp "account1 \nif foo\n account2 foo\n" @?= - (Right (mkrules $ defrules{rassignments = [("account1","")], rconditionalblocks = [CB{cbMatchers=[RecordMatcher None "foo"],cbAssignments=[("account2","foo")]}]})) + (Right (mkrules $ defrules{rassignments = [("account1","")], rconditionalblocks = [CB{cbMatchers=[RecordMatcher None (toRegex' "foo")],cbAssignments=[("account2","foo")]}]})) ] ,tests "conditionalblockp" [ test "space after conditional" $ -- #1120 parseWithState' defrules conditionalblockp "if a\n account2 b\n \n" @?= - (Right $ CB{cbMatchers=[RecordMatcher None "a"],cbAssignments=[("account2","b")]}) + (Right $ CB{cbMatchers=[RecordMatcher None $ toRegexCI' "a"],cbAssignments=[("account2","b")]}) ,tests "csvfieldreferencep" [ test "number" $ parseWithState' defrules csvfieldreferencep "%1" @?= (Right "%1") @@ -1272,19 +1272,19 @@ tests_CsvReader = tests "CsvReader" [ ,tests "matcherp" [ test "recordmatcherp" $ - parseWithState' defrules matcherp "A A\n" @?= (Right $ RecordMatcher None "A A") + parseWithState' defrules matcherp "A A\n" @?= (Right $ RecordMatcher None $ toRegexCI' "A A") ,test "recordmatcherp.starts-with-&" $ - parseWithState' defrules matcherp "& A A\n" @?= (Right $ RecordMatcher And "A A") + parseWithState' defrules matcherp "& A A\n" @?= (Right $ RecordMatcher And $ toRegexCI' "A A") ,test "fieldmatcherp.starts-with-%" $ - parseWithState' defrules matcherp "description A A\n" @?= (Right $ RecordMatcher None "description A A") + parseWithState' defrules matcherp "description A A\n" @?= (Right $ RecordMatcher None $ toRegexCI' "description A A") ,test "fieldmatcherp" $ - parseWithState' defrules matcherp "%description A A\n" @?= (Right $ FieldMatcher None "%description" "A A") + parseWithState' defrules matcherp "%description A A\n" @?= (Right $ FieldMatcher None "%description" $ toRegexCI' "A A") ,test "fieldmatcherp.starts-with-&" $ - parseWithState' defrules matcherp "& %description A A\n" @?= (Right $ FieldMatcher And "%description" "A A") + parseWithState' defrules matcherp "& %description A A\n" @?= (Right $ FieldMatcher And "%description" $ toRegexCI' "A A") -- ,test "fieldmatcherp with operator" $ -- parseWithState' defrules matcherp "%description ~ A A\n" @?= (Right $ FieldMatcher "%description" "A A") @@ -1293,22 +1293,22 @@ tests_CsvReader = tests "CsvReader" [ ,tests "getEffectiveAssignment" [ let rules = mkrules $ defrules {rcsvfieldindexes=[("csvdate",1)],rassignments=[("date","%csvdate")]} - + in test "toplevel" $ getEffectiveAssignment rules ["a","b"] "date" @?= (Just "%csvdate") - ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" "a"] [("date","%csvdate")]]} + ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a"] [("date","%csvdate")]]} in test "conditional" $ getEffectiveAssignment rules ["a","b"] "date" @?= (Just "%csvdate") - ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" "a", FieldMatcher None "%description" "b"] [("date","%csvdate")]]} + ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher None "%description" $ toRegex' "b"] [("date","%csvdate")]]} in test "conditional-with-or-a" $ getEffectiveAssignment rules ["a"] "date" @?= (Just "%csvdate") - ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" "a", FieldMatcher None "%description" "b"] [("date","%csvdate")]]} + ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher None "%description" $ toRegex' "b"] [("date","%csvdate")]]} in test "conditional-with-or-b" $ getEffectiveAssignment rules ["_", "b"] "date" @?= (Just "%csvdate") - ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" "a", FieldMatcher And "%description" "b"] [("date","%csvdate")]]} + ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher And "%description" $ toRegex' "b"] [("date","%csvdate")]]} in test "conditional.with-and" $ getEffectiveAssignment rules ["a", "b"] "date" @?= (Just "%csvdate") - ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" "a", FieldMatcher And "%description" "b", FieldMatcher None "%description" "c"] [("date","%csvdate")]]} + ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher And "%description" $ toRegex' "b", FieldMatcher None "%description" $ toRegex' "c"] [("date","%csvdate")]]} in test "conditional.with-and-or" $ getEffectiveAssignment rules ["_", "c"] "date" @?= (Just "%csvdate") ] diff --git a/hledger-lib/Hledger/Read/JournalReader.hs b/hledger-lib/Hledger/Read/JournalReader.hs index 4ac159743..3d2749d5c 100644 --- a/hledger-lib/Hledger/Read/JournalReader.hs +++ b/hledger-lib/Hledger/Read/JournalReader.hs @@ -529,8 +529,8 @@ regexaliasp = do char '=' skipNonNewlineSpaces repl <- anySingle `manyTill` eolof - case toRegex_ re of - Right _ -> return $! RegexAlias re repl + case toRegexCI_ re of + Right r -> return $! RegexAlias r repl Left e -> customFailure $! parseErrorAtRegion off1 off2 e endaliasesdirectivep :: JournalParser m () diff --git a/hledger-lib/Hledger/Reports/EntriesReport.hs b/hledger-lib/Hledger/Reports/EntriesReport.hs index b1249c1da..fb1c15b72 100644 --- a/hledger-lib/Hledger/Reports/EntriesReport.hs +++ b/hledger-lib/Hledger/Reports/EntriesReport.hs @@ -50,7 +50,7 @@ entriesReport ropts@ReportOpts{..} q j@Journal{..} = tests_EntriesReport = tests "EntriesReport" [ tests "entriesReport" [ - test "not acct" $ (length $ entriesReport defreportopts (Not $ Acct "bank") samplejournal) @?= 1 + test "not acct" $ (length $ entriesReport defreportopts (Not . Acct $ toRegex' "bank") samplejournal) @?= 1 ,test "date" $ (length $ entriesReport defreportopts (Date $ DateSpan (Just $ fromGregorian 2008 06 01) (Just $ fromGregorian 2008 07 01)) samplejournal) @?= 3 ] ] diff --git a/hledger-lib/Hledger/Reports/PostingsReport.hs b/hledger-lib/Hledger/Reports/PostingsReport.hs index 862d91951..bb9bccc5a 100644 --- a/hledger-lib/Hledger/Reports/PostingsReport.hs +++ b/hledger-lib/Hledger/Reports/PostingsReport.hs @@ -277,13 +277,13 @@ tests_PostingsReport = tests "PostingsReport" [ (Any, samplejournal) `gives` 13 -- register --depth just clips account names (Depth 2, samplejournal) `gives` 13 - (And [Depth 1, StatusQ Cleared, Acct "expenses"], samplejournal) `gives` 2 - (And [And [Depth 1, StatusQ Cleared], Acct "expenses"], samplejournal) `gives` 2 + (And [Depth 1, StatusQ Cleared, Acct (toRegex' "expenses")], samplejournal) `gives` 2 + (And [And [Depth 1, StatusQ Cleared], Acct (toRegex' "expenses")], samplejournal) `gives` 2 -- with query and/or command-line options (length $ snd $ postingsReport defreportopts Any samplejournal) @?= 13 (length $ snd $ postingsReport defreportopts{interval_=Months 1} Any samplejournal) @?= 11 (length $ snd $ postingsReport defreportopts{interval_=Months 1, empty_=True} Any samplejournal) @?= 20 - (length $ snd $ postingsReport defreportopts (Acct "assets:bank:checking") samplejournal) @?= 5 + (length $ snd $ postingsReport defreportopts (Acct (toRegex' "assets:bank:checking")) samplejournal) @?= 5 -- (defreportopts, And [Acct "a a", Acct "'b"], samplejournal2) `gives` 0 -- [(Just (fromGregorian 2008 01 01,"income"),assets:bank:checking $1,$1) diff --git a/hledger-lib/Hledger/Reports/ReportOptions.hs b/hledger-lib/Hledger/Reports/ReportOptions.hs index c6dea8783..3436d24f5 100644 --- a/hledger-lib/Hledger/Reports/ReportOptions.hs +++ b/hledger-lib/Hledger/Reports/ReportOptions.hs @@ -346,7 +346,7 @@ forecastPeriodFromRawOpts d opts = Just str -> either (\e -> usageError $ "could not parse forecast period : "++customErrorBundlePretty e) (Just . snd) $ parsePeriodExpr d $ stripquotes $ T.pack str - + -- | Extract the interval from the parsed -p/--period expression. -- Return Nothing if an interval is not explicitly defined. extractIntervalOrNothing :: (Interval, DateSpan) -> Maybe Interval @@ -423,10 +423,10 @@ type DisplayExp = String maybedisplayopt :: Day -> RawOpts -> Maybe DisplayExp maybedisplayopt d rawopts = - maybe Nothing (Just . regexReplaceBy "\\[.+?\\]" fixbracketeddatestr) $ maybestringopt "display" rawopts - where - fixbracketeddatestr "" = "" - fixbracketeddatestr s = "[" ++ fixSmartDateStr d (T.pack $ init $ tail s) ++ "]" + maybe Nothing (Just . replaceAllBy (toRegex' "\\[.+?\\]") fixbracketeddatestr) $ maybestringopt "display" rawopts + where + fixbracketeddatestr "" = "" + fixbracketeddatestr s = "[" ++ fixSmartDateStr d (T.pack $ init $ tail s) ++ "]" -- | Select the Transaction date accessor based on --date2. transactionDateFn :: ReportOpts -> (Transaction -> Day) @@ -573,12 +573,12 @@ reportPeriodOrJournalLastDay ropts j = tests_ReportOptions = tests "ReportOptions" [ test "queryFromOpts" $ do queryFromOpts nulldate defreportopts @?= Any - queryFromOpts nulldate defreportopts{query_="a"} @?= Acct "a" - queryFromOpts nulldate defreportopts{query_="desc:'a a'"} @?= Desc "a a" + queryFromOpts nulldate defreportopts{query_="a"} @?= Acct (toRegexCI' "a") + queryFromOpts nulldate defreportopts{query_="desc:'a a'"} @?= Desc (toRegexCI' "a a") queryFromOpts nulldate defreportopts{period_=PeriodFrom (fromGregorian 2012 01 01),query_="date:'to 2013'" } @?= (Date $ DateSpan (Just $ fromGregorian 2012 01 01) (Just $ fromGregorian 2013 01 01)) queryFromOpts nulldate defreportopts{query_="date2:'in 2012'"} @?= (Date2 $ DateSpan (Just $ fromGregorian 2012 01 01) (Just $ fromGregorian 2013 01 01)) - queryFromOpts nulldate defreportopts{query_="'a a' 'b"} @?= Or [Acct "a a", Acct "'b"] + queryFromOpts nulldate defreportopts{query_="'a a' 'b"} @?= Or [Acct $ toRegexCI' "a a", Acct $ toRegexCI' "'b"] ,test "queryOptsFromOpts" $ do queryOptsFromOpts nulldate defreportopts @?= [] @@ -586,4 +586,3 @@ tests_ReportOptions = tests "ReportOptions" [ queryOptsFromOpts nulldate defreportopts{period_=PeriodFrom (fromGregorian 2012 01 01) ,query_="date:'to 2013'"} @?= [] ] - diff --git a/hledger-lib/Hledger/Utils/Regex.hs b/hledger-lib/Hledger/Utils/Regex.hs index d3ccb6d7c..3ffa35105 100644 --- a/hledger-lib/Hledger/Utils/Regex.hs +++ b/hledger-lib/Hledger/Utils/Regex.hs @@ -1,4 +1,8 @@ -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} {-| Easy regular expression helpers, currently based on regex-tdfa. These should: @@ -42,48 +46,120 @@ Current limitations: -} module Hledger.Utils.Regex ( + -- * Regexp type and constructors + Regexp(reString) + ,toRegex_ + ,toRegexCI_ + ,toRegex' + ,toRegexCI' -- * type aliases - Regexp ,Replacement ,RegexError -- * partial regex operations (may call error) - ,regexMatches - ,regexMatchesCI - ,regexReplace - ,regexReplaceCI - ,regexReplaceMemo - ,regexReplaceCIMemo - ,regexReplaceBy - ,regexReplaceByCI +-- ,regexMatches +-- ,regexMatchesCI +-- ,regexReplaceCI +-- ,regexReplaceCIMemo +-- ,regexReplaceByCI -- * total regex operations - ,regexMatches_ - ,regexMatchesCI_ - ,regexReplace_ - ,regexReplaceCI_ + ,match + ,regexReplace ,regexReplaceMemo_ - ,regexReplaceCIMemo_ - ,regexReplaceBy_ - ,regexReplaceByCI_ - ,toRegex_ +-- ,replaceAllBy +-- ,regexMatches_ +-- ,regexMatchesCI_ +-- ,regexReplace_ +-- ,regexReplaceCI_ +-- ,regexReplaceMemo_ +-- ,regexReplaceCIMemo_ + ,replaceAllBy ) where +import Control.Arrow (first) import Control.Monad (foldM) -import Data.Array -import Data.Char +import Data.Aeson (ToJSON(..), Value(String)) +import Data.Array ((!), elems, indices) +import Data.Char (isDigit) +import Data.Data (Data(..), mkNoRepType) import Data.List (foldl') -import Data.Maybe (fromMaybe) import Data.MemoUgly (memo) +import qualified Data.Text as T import Text.Regex.TDFA ( - Regex, CompOption(..), ExecOption(..), defaultCompOpt, defaultExecOpt, - makeRegexOptsM, AllMatches(getAllMatches), match, (=~), MatchText + Regex, CompOption(..), defaultCompOpt, defaultExecOpt, + makeRegexOptsM, AllMatches(getAllMatches), match, MatchText, + RegexLike(..), RegexMaker(..), RegexOptions(..), RegexContext(..) ) import Hledger.Utils.UTF8IOCompat (error') -- | Regular expression. Extended regular expression-ish syntax ? But does not support eg (?i) syntax. -type Regexp = String +data Regexp + = Regexp { reString :: String, reCompiled :: Regex } + | RegexpCI { reString :: String, reCompiled :: Regex } + +instance Eq Regexp where + Regexp s1 _ == Regexp s2 _ = s1 == s2 + RegexpCI s1 _ == RegexpCI s2 _ = s1 == s2 + _ == _ = False + +instance Ord Regexp where + Regexp s1 _ `compare` Regexp s2 _ = s1 `compare` s2 + RegexpCI s1 _ `compare` RegexpCI s2 _ = s1 `compare` s2 + Regexp _ _ `compare` RegexpCI _ _ = LT + RegexpCI _ _ `compare` Regexp _ _ = GT + +instance Show Regexp where + showsPrec d (Regexp s _) = showString "Regexp " . showsPrec d s + showsPrec d (RegexpCI s _) = showString "RegexpCI " . showsPrec d s + +instance Read Regexp where + readsPrec d ('R':'e':'g':'e':'x':'p':' ':xs) = map (first toRegex') $ readsPrec d xs + readsPrec d ('R':'e':'g':'e':'x':'p':'C':'I':' ':xs) = map (first toRegexCI') $ readsPrec d xs + readsPrec _ s = error' $ "read: Not a valid regex " ++ s + +instance Data Regexp where + toConstr _ = error' "No toConstr for Regex" + gunfold _ _ = error' "No gunfold for Regex" + dataTypeOf _ = mkNoRepType "Hledger.Utils.Regex" + +instance ToJSON Regexp where + toJSON (Regexp s _) = String . T.pack $ "Regexp " ++ s + toJSON (RegexpCI s _) = String . T.pack $ "RegexpCI " ++ s + +instance RegexLike Regexp String where + matchOnce = matchOnce . reCompiled + matchAll = matchAll . reCompiled + matchCount = matchCount . reCompiled + matchTest = matchTest . reCompiled + matchAllText = matchAllText . reCompiled + matchOnceText = matchOnceText . reCompiled + +instance RegexContext Regexp String String where + match = match . reCompiled + matchM = matchM . reCompiled + +-- Convert a Regexp string to a compiled Regex, or return an error message. +toRegex_ :: String -> Either RegexError Regexp +toRegex_ = memo $ \s -> mkRegexErr s (Regexp s <$> makeRegexM s) + +-- Like toRegex_, but make a case-insensitive Regex. +toRegexCI_ :: String -> Either RegexError Regexp +toRegexCI_ = memo $ \s -> mkRegexErr s (RegexpCI s <$> makeRegexOptsM defaultCompOpt{caseSensitive=False} defaultExecOpt s) + +-- | Make a nice error message for a regexp error. +mkRegexErr :: String -> Maybe a -> Either RegexError a +mkRegexErr s = maybe (Left errmsg) Right + where errmsg = "this regular expression could not be compiled: " ++ s + +-- Convert a Regexp string to a compiled Regex, throw an error +toRegex' :: String -> Regexp +toRegex' = either error' id . toRegex_ + +-- Like toRegex', but make a case-insensitive Regex. +toRegexCI' :: String -> Regexp +toRegexCI' = either error' id . toRegexCI_ -- | A replacement pattern. May include numeric backreferences (\N). type Replacement = String @@ -91,61 +167,10 @@ type Replacement = String -- | An regular expression compilation/processing error message. type RegexError = String --------------------------------------------------------------------------------- --- old partial functions -- PARTIAL: - --- regexMatch' :: RegexContext Regexp String a => Regexp -> String -> a --- regexMatch' r s = s =~ (toRegex' r) - -regexMatches :: Regexp -> String -> Bool -regexMatches = flip (=~) - -regexMatchesCI :: Regexp -> String -> Bool -regexMatchesCI r = match (toRegexCI r) - --- | Replace all occurrences of the regexp with the replacement --- pattern. The replacement pattern supports numeric backreferences --- (\N) but no other RE syntax. -regexReplace :: Regexp -> Replacement -> String -> String -regexReplace re = replaceRegex (toRegex re) - -regexReplaceCI :: Regexp -> Replacement -> String -> String -regexReplaceCI re = replaceRegex (toRegexCI re) - --- | A memoising version of regexReplace. Caches the result for each --- search pattern, replacement pattern, target string tuple. -regexReplaceMemo :: Regexp -> Replacement -> String -> String -regexReplaceMemo re repl = memo (regexReplace re repl) - -regexReplaceCIMemo :: Regexp -> Replacement -> String -> String -regexReplaceCIMemo re repl = memo (regexReplaceCI re repl) - --- | Replace all occurrences of the regexp, transforming each match with the given function. -regexReplaceBy :: Regexp -> (String -> String) -> String -> String -regexReplaceBy r = replaceAllBy (toRegex r) - -regexReplaceByCI :: Regexp -> (String -> String) -> String -> String -regexReplaceByCI r = replaceAllBy (toRegexCI r) - -- helpers --- | Convert our string-based Regexp to a real Regex. --- Or if it's not well formed, call error with a "malformed regexp" message. -toRegex :: Regexp -> Regex -toRegex = memo (compileRegex defaultCompOpt defaultExecOpt) -- PARTIAL: - --- | Like toRegex but make a case-insensitive Regex. -toRegexCI :: Regexp -> Regex -toRegexCI = memo (compileRegex defaultCompOpt{caseSensitive=False} defaultExecOpt) -- PARTIAL: - -compileRegex :: CompOption -> ExecOption -> Regexp -> Regex -compileRegex compopt execopt r = - fromMaybe - (error $ "this regular expression could not be compiled: " ++ show r) $ -- PARTIAL: - makeRegexOptsM compopt execopt r - -replaceRegex :: Regex -> Replacement -> String -> String -replaceRegex re repl s = foldl (replaceMatch repl) s (reverse $ match re s :: [MatchText String]) +regexReplace :: Regexp -> Replacement -> String -> String +regexReplace re repl s = foldl (replaceMatch repl) s (reverse $ match (reCompiled re) s :: [MatchText String]) where replaceMatch :: Replacement -> String -> MatchText String -> String replaceMatch replpat s matchgroups = pre ++ repl ++ post @@ -153,7 +178,7 @@ replaceRegex re repl s = foldl (replaceMatch repl) s (reverse $ match re s :: [M ((_,(off,len)):_) = elems matchgroups -- groups should have 0-based indexes, and there should always be at least one, since this is a match (pre, post') = splitAt off s post = drop len post' - repl = replaceAllBy (toRegex "\\\\[0-9]+") (lookupMatchGroup matchgroups) replpat + repl = replaceAllBy backrefRegex (lookupMatchGroup matchgroups) replpat where lookupMatchGroup :: MatchText String -> String -> String lookupMatchGroup grps ('\\':s@(_:_)) | all isDigit s = @@ -161,68 +186,22 @@ replaceRegex re repl s = foldl (replaceMatch repl) s (reverse $ match re s :: [M -- PARTIAL: _ -> error' $ "no match group exists for backreference \"\\"++s++"\"" lookupMatchGroup _ s = error' $ "lookupMatchGroup called on non-numeric-backreference \""++s++"\", shouldn't happen" + backrefRegex = toRegex' "\\\\[0-9]+" -- PARTIAL: should not error happen -------------------------------------------------------------------------------- -- new total functions --- | Does this regexp match the given string ? --- Or return an error if the regexp is malformed. -regexMatches_ :: Regexp -> String -> Either RegexError Bool -regexMatches_ r s = (`match` s) <$> toRegex_ r - --- | Like regexMatches_ but match case-insensitively. -regexMatchesCI_ :: Regexp -> String -> Either RegexError Bool -regexMatchesCI_ r s = (`match` s) <$> toRegexCI_ r - --- | Replace all occurrences of the regexp with the replacement --- pattern, or return an error message. The replacement pattern --- supports numeric backreferences (\N) but no other RE syntax. -regexReplace_ :: Regexp -> Replacement -> String -> Either RegexError String -regexReplace_ re repl s = toRegex_ re >>= \rx -> replaceRegex_ rx repl s - --- | Like regexReplace_ but match occurrences case-insensitively. -regexReplaceCI_ :: Regexp -> Replacement -> String -> Either RegexError String -regexReplaceCI_ re repl s = toRegexCI_ re >>= \rx -> replaceRegex_ rx repl s - -- | A memoising version of regexReplace_. Caches the result for each -- search pattern, replacement pattern, target string tuple. regexReplaceMemo_ :: Regexp -> Replacement -> String -> Either RegexError String -regexReplaceMemo_ re repl = memo (regexReplace_ re repl) - --- | Like regexReplaceMemo_ but match occurrences case-insensitively. -regexReplaceCIMemo_ :: Regexp -> Replacement -> String -> Either RegexError String -regexReplaceCIMemo_ re repl = memo (regexReplaceCI_ re repl) - --- | Replace all occurrences of the regexp, transforming each match --- with the given function, or return an error message. -regexReplaceBy_ :: Regexp -> (String -> String) -> String -> Either RegexError String -regexReplaceBy_ r f s = toRegex_ r >>= \rx -> Right $ replaceAllBy rx f s - --- | Like regexReplaceBy_ but match occurrences case-insensitively. -regexReplaceByCI_ :: Regexp -> (String -> String) -> String -> Either RegexError String -regexReplaceByCI_ r f s = toRegexCI_ r >>= \rx -> Right $ replaceAllBy rx f s +regexReplaceMemo_ re repl = memo (replaceRegexUnmemo_ re repl) -- helpers: --- Convert a Regexp string to a compiled Regex, or return an error message. -toRegex_ :: Regexp -> Either RegexError Regex -toRegex_ = memo (compileRegex_ defaultCompOpt defaultExecOpt) - --- Like toRegex, but make a case-insensitive Regex. -toRegexCI_ :: Regexp -> Either RegexError Regex -toRegexCI_ = memo (compileRegex_ defaultCompOpt{caseSensitive=False} defaultExecOpt) - --- Compile a Regexp string to a Regex with the given options, or return an --- error message if this fails. -compileRegex_ :: CompOption -> ExecOption -> Regexp -> Either RegexError Regex -compileRegex_ compopt execopt r = - maybe (Left $ "this regular expression could not be compiled: " ++ show r) Right $ - makeRegexOptsM compopt execopt r - -- Replace this regular expression with this replacement pattern in this -- string, or return an error message. -replaceRegex_ :: Regex -> Replacement -> String -> Either RegexError String -replaceRegex_ re repl s = foldM (replaceMatch_ repl) s (reverse $ match re s :: [MatchText String]) +replaceRegexUnmemo_ :: Regexp -> Replacement -> String -> Either RegexError String +replaceRegexUnmemo_ re repl s = foldM (replaceMatch_ repl) s (reverse $ match (reCompiled re) s :: [MatchText String]) where -- Replace one match within the string with the replacement text -- appropriate for this match. Or return an error message. @@ -236,7 +215,8 @@ replaceRegex_ re repl s = foldM (replaceMatch_ repl) s (reverse $ match re s :: -- The replacement text: the replacement pattern with all -- numeric backreferences replaced by the appropriate groups -- from this match. Or an error message. - erepl = toRegex_ "\\\\[0-9]+" >>= \rx -> replaceAllByM rx (lookupMatchGroup_ matchgroups) replpat + -- FIXME: Use makeRegex instead of toRegex_ + erepl = replaceAllByM backrefRegex (lookupMatchGroup_ matchgroups) replpat where -- Given some match groups and a numeric backreference, -- return the referenced group text, or an error message. @@ -245,6 +225,7 @@ replaceRegex_ re repl s = foldM (replaceMatch_ repl) s (reverse $ match re s :: case read s of n | n `elem` indices grps -> Right $ fst (grps ! n) _ -> Left $ "no match group exists for backreference \"\\"++s++"\"" lookupMatchGroup_ _ s = Left $ "lookupMatchGroup called on non-numeric-backreference \""++s++"\", shouldn't happen" + backrefRegex = toRegex' "\\\\[0-9]+" -- PARTIAL: should not happen -- helpers @@ -252,12 +233,12 @@ replaceRegex_ re repl s = foldM (replaceMatch_ repl) s (reverse $ match re s :: -- Replace all occurrences of a regexp in a string, transforming each match -- with the given pure function. -replaceAllBy :: Regex -> (String -> String) -> String -> String +replaceAllBy :: Regexp -> (String -> String) -> String -> String replaceAllBy re transform s = prependdone rest where (_, rest, prependdone) = foldl' go (0, s, id) matches where - matches = getAllMatches $ match re s :: [(Int, Int)] -- offset and length + matches = getAllMatches $ match (reCompiled re) s :: [(Int, Int)] -- offset and length go :: (Int,String,String->String) -> (Int,Int) -> (Int,String,String->String) go (pos,todo,prepend) (off,len) = let (prematch, matchandrest) = splitAt (off - pos) todo @@ -268,11 +249,11 @@ replaceAllBy re transform s = prependdone rest -- with the given monadic function. Eg if the monad is Either, a Left result -- from the transform function short-circuits and is returned as the overall -- result. -replaceAllByM :: forall m. Monad m => Regex -> (String -> m String) -> String -> m String +replaceAllByM :: forall m. Monad m => Regexp -> (String -> m String) -> String -> m String replaceAllByM re transform s = foldM go (0, s, id) matches >>= \(_, rest, prependdone) -> pure $ prependdone rest where - matches = getAllMatches $ match re s :: [(Int, Int)] -- offset and length + matches = getAllMatches $ match (reCompiled re) s :: [(Int, Int)] -- offset and length go :: (Int,String,String->String) -> (Int,Int) -> m (Int,String,String->String) go (pos,todo,prepend) (off,len) = let (prematch, matchandrest) = splitAt (off - pos) todo diff --git a/hledger-lib/Hledger/Utils/String.hs b/hledger-lib/Hledger/Utils/String.hs index 8d1458f74..41923e495 100644 --- a/hledger-lib/Hledger/Utils/String.hs +++ b/hledger-lib/Hledger/Utils/String.hs @@ -134,10 +134,10 @@ whitespacechars = " \t\n\r" redirectchars = "<>" escapeDoubleQuotes :: String -> String -escapeDoubleQuotes = regexReplace "\"" "\"" +escapeDoubleQuotes = id -- regexReplace "\"" "\"" escapeQuotes :: String -> String -escapeQuotes = regexReplace "([\"'])" "\\1" +escapeQuotes = id -- regexReplace "([\"'])" "\\1" -- | Quote-aware version of words - don't split on spaces which are inside quotes. -- NB correctly handles "a'b" but not "''a''". Can raise an error if parsing fails. @@ -346,7 +346,7 @@ strWidth s = maximum $ map (foldr (\a b -> charWidth a + b) 0) $ lines s' where s' = stripAnsi s stripAnsi :: String -> String -stripAnsi = regexReplace "\ESC\\[([0-9]+;)*([0-9]+)?[ABCDHJKfmsu]" "" +stripAnsi = regexReplace (toRegex' "\ESC\\[([0-9]+;)*([0-9]+)?[ABCDHJKfmsu]") "" -- PARTIAL: should never happen, no backreferences -- | Get the designated render width of a character: 0 for a combining -- character, 1 for a regular character, 2 for a wide character. diff --git a/hledger-ui/Hledger/UI/AccountsScreen.hs b/hledger-ui/Hledger/UI/AccountsScreen.hs index 05c5e0b5a..2e144f422 100644 --- a/hledger-ui/Hledger/UI/AccountsScreen.hs +++ b/hledger-ui/Hledger/UI/AccountsScreen.hs @@ -90,7 +90,7 @@ asInit d reset ui@UIState{ excludeforecastq Nothing = -- not:date:tomorrow- not:tag:generated-transaction And [ Not (Date $ DateSpan (Just $ addDays 1 d) Nothing) - ,Not (Tag "generated-transaction" Nothing) + ,Not (Tag (toRegexCI' "generated-transaction") Nothing) ] -- run the report diff --git a/hledger-ui/Hledger/UI/Main.hs b/hledger-ui/Hledger/UI/Main.hs index a8fed5891..612631d9d 100644 --- a/hledger-ui/Hledger/UI/Main.hs +++ b/hledger-ui/Hledger/UI/Main.hs @@ -122,7 +122,7 @@ runBrickUi uopts@UIOpts{cliopts_=copts@CliOpts{inputopts_=_iopts,reportopts_=rop where acct = headDef (error' $ "--register "++apat++" did not match any account") -- PARTIAL: - $ filter (regexMatches apat . T.unpack) $ journalAccountNames j + $ filter (match (toRegexCI' apat) . T.unpack) $ journalAccountNames j -- Initialising the accounts screen is awkward, requiring -- another temporary UIState value.. ascr' = aScreen $ diff --git a/hledger-ui/Hledger/UI/RegisterScreen.hs b/hledger-ui/Hledger/UI/RegisterScreen.hs index 1551b2382..5893f32a2 100644 --- a/hledger-ui/Hledger/UI/RegisterScreen.hs +++ b/hledger-ui/Hledger/UI/RegisterScreen.hs @@ -76,7 +76,7 @@ rsInit d reset ui@UIState{aopts=_uopts@UIOpts{cliopts_=CliOpts{reportopts_=ropts excludeforecastq Nothing = -- not:date:tomorrow- not:tag:generated-transaction And [ Not (Date $ DateSpan (Just $ addDays 1 d) Nothing) - ,Not (Tag "generated-transaction" Nothing) + ,Not (Tag (toRegexCI' "generated-transaction") Nothing) ] (_label,items) = accountTransactionsReport ropts' j q thisacctq diff --git a/hledger-web/Hledger/Web/Widget/AddForm.hs b/hledger-web/Hledger/Web/Widget/AddForm.hs index 7119aaec0..e47644118 100644 --- a/hledger-web/Hledger/Web/Widget/AddForm.hs +++ b/hledger-web/Hledger/Web/Widget/AddForm.hs @@ -115,7 +115,7 @@ addForm j today = identifyForm "add" $ \extra -> do ] where -- avoid https://github.com/simonmichael/hledger/issues/236 - escapeJSSpecialChars = regexReplaceCI "" "<\\/script>" + escapeJSSpecialChars = regexReplace (toRegexCI' "") "<\\/script>" validateTransaction :: FormResult Day diff --git a/hledger-web/Hledger/Web/Widget/Common.hs b/hledger-web/Hledger/Web/Widget/Common.hs index c18b887a1..908c6e26e 100644 --- a/hledger-web/Hledger/Web/Widget/Common.hs +++ b/hledger-web/Hledger/Web/Widget/Common.hs @@ -72,7 +72,7 @@ writeJournalTextIfValidAndChanged f t = do -- Ensure unix line endings, since both readJournal (cf -- formatdirectivep, #1194) writeFileWithBackupIfChanged require them. -- XXX klunky. Any equivalent of "hSetNewlineMode h universalNewlineMode" for form posts ? - let t' = T.pack $ regexReplace "\r" "" $ T.unpack t + let t' = T.pack $ regexReplace (toRegex' "\r") "" $ T.unpack t liftIO (readJournal def (Just f) t') >>= \case Left e -> return (Left e) Right _ -> do diff --git a/hledger/Hledger/Cli/Commands.hs b/hledger/Hledger/Cli/Commands.hs index 17d5bf55f..ff3283872 100644 --- a/hledger/Hledger/Cli/Commands.hs +++ b/hledger/Hledger/Cli/Commands.hs @@ -61,7 +61,7 @@ import System.Environment (withArgs) import System.Console.CmdArgs.Explicit as C import Test.Tasty (defaultMain) -import Hledger +import Hledger import Hledger.Cli.CliOptions import Hledger.Cli.Version import Hledger.Cli.Commands.Accounts @@ -137,7 +137,7 @@ builtinCommands = [ -- | The commands list, showing command names, standard aliases, -- and short descriptions. This is modified at runtime, as follows: -- --- PROGVERSION is replaced with the program name and version. +-- progversion is the program name and version. -- -- Lines beginning with a space represent builtin commands, with format: -- COMMAND (ALIASES) DESCRIPTION @@ -152,10 +152,10 @@ builtinCommands = [ -- -- TODO: generate more of this automatically. -- -commandsList :: String -commandsList = unlines [ +commandsList :: String -> [String] -> [String] +commandsList progversion othercmds = [ "-------------------------------------------------------------------------------" - ,"PROGVERSION" + ,progversion ,"Usage: hledger COMMAND [OPTIONS] [-- ADDONCMDOPTIONS]" ,"Commands (+ addons found in $PATH):" ,"" @@ -208,8 +208,10 @@ commandsList = unlines [ ,"+api run http api server" ,"" ,"Other:" - ,"OTHER" - ,"Help:" + ] ++ + othercmds + ++ + ["Help:" ," (no arguments) show this commands list" ," -h show general flags" ," COMMAND -h show flags & docs for COMMAND" @@ -231,25 +233,21 @@ findCommand cmdname = find (elem cmdname . modeNames . fst) builtinCommands -- | Extract the command names from commandsList: the first word -- of lines beginning with a space or + sign. -commandsFromCommandsList :: String -> [String] +commandsFromCommandsList :: [String] -> [String] commandsFromCommandsList s = - [w | c:l <- lines s, c `elem` [' ','+'], let w:_ = words l] + [w | c:l <- s, c `elem` [' ','+'], let w:_ = words l] knownCommands :: [String] -knownCommands = sort $ commandsFromCommandsList commandsList +knownCommands = sort . commandsFromCommandsList $ commandsList prognameandversion [] -- | Print the commands list, modifying the template above based on -- the currently available addons. Missing addons will be removed, and -- extra addons will be added under Misc. printCommandsList :: [String] -> IO () printCommandsList addonsFound = - putStr $ - regexReplace "PROGVERSION" (prognameandversion) $ - regexReplace "OTHER" (unlines $ (map ('+':) unknownCommandsFound)) $ - unlines $ concatMap adjustline $ lines $ - cmdlist + putStr . unlines . concatMap adjustline $ + commandsList prognameandversion (map ('+':) unknownCommandsFound) where - cmdlist = commandsList commandsFound = map (' ':) builtinCommandNames ++ map ('+':) addonsFound unknownCommandsFound = addonsFound \\ knownCommands diff --git a/hledger/Hledger/Cli/Commands/Aregister.hs b/hledger/Hledger/Cli/Commands/Aregister.hs index cd84899c4..5be44e257 100644 --- a/hledger/Hledger/Cli/Commands/Aregister.hs +++ b/hledger/Hledger/Cli/Commands/Aregister.hs @@ -24,7 +24,9 @@ import Data.Aeson (toJSON) import Data.Aeson.Text (encodeToLazyText) import Data.List import Data.Maybe --- import Data.Text (Text) +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup ((<>)) +#endif import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Data.Time (addDays) @@ -77,8 +79,9 @@ aregister opts@CliOpts{rawopts_=rawopts,reportopts_=ropts} j = do when (null args') $ error' "aregister needs an account, please provide an account name or pattern" -- PARTIAL: let (apat:queryargs) = args' + apatregex = toRegex' apat -- PARTIAL: do better acct = headDef (error' $ show apat++" did not match any account") $ -- PARTIAL: - filter (regexMatches apat . T.unpack) $ journalAccountNames j + filter (match apatregex . T.unpack) $ journalAccountNames j -- gather report options inclusive = True -- tree_ ropts thisacctq = Acct $ (if inclusive then accountNameToAccountRegex else accountNameToAccountOnlyRegex) acct @@ -97,7 +100,7 @@ aregister opts@CliOpts{rawopts_=rawopts,reportopts_=ropts} j = do excludeforecastq False = -- not:date:tomorrow- not:tag:generated-transaction And [ Not (Date $ DateSpan (Just $ addDays 1 d) Nothing) - ,Not (Tag "generated-transaction" Nothing) + ,Not (Tag (toRegex' "generated-transaction") Nothing) ] -- run the report -- TODO: need to also pass the queries so we can choose which date to render - move them into the report ? @@ -147,11 +150,11 @@ accountTransactionsReportAsText itemamt (_,_,_,_,a,_) = a itembal (_,_,_,_,_,a) = a -- show a title indicating which account was picked, which can be confusing otherwise - title = maybe "" (("Transactions in "++).(++" and subaccounts:")) macct + title = T.unpack $ maybe "" (("Transactions in "<>).(<>" and subaccounts:")) macct where -- XXX temporary hack ? recover the account name from the query macct = case filterQuery queryIsAcct thisacctq of - Acct r -> Just $ init $ init $ init $ init $ init $ tail r -- Acct "^JS:expenses(:|$)" + Acct r -> Just . T.drop 1 . T.dropEnd 5 . T.pack $ reString r -- Acct "^JS:expenses(:|$)" _ -> Nothing -- shouldn't happen -- | Render one account register report line item as plain text. Layout is like so: diff --git a/hledger/Hledger/Cli/Commands/Files.hs b/hledger/Hledger/Cli/Commands/Files.hs index ece5ca474..1d80f28f8 100644 --- a/hledger/Hledger/Cli/Commands/Files.hs +++ b/hledger/Hledger/Cli/Commands/Files.hs @@ -33,8 +33,8 @@ filesmode = hledgerCommandMode files :: CliOpts -> Journal -> IO () files CliOpts{rawopts_=rawopts} j = do let args = listofstringopt "args" rawopts - regex = headMay args - files = maybe id (filter . regexMatches) regex + regex <- mapM (either fail pure . toRegex_) $ headMay args + let files = maybe id (filter . match) regex $ map fst $ jfiles j mapM_ putStrLn files diff --git a/hledger/Hledger/Cli/Commands/Tags.hs b/hledger/Hledger/Cli/Commands/Tags.hs index 03242d4df..c6e395226 100755 --- a/hledger/Hledger/Cli/Commands/Tags.hs +++ b/hledger/Hledger/Cli/Commands/Tags.hs @@ -7,6 +7,7 @@ module Hledger.Cli.Commands.Tags ( ) where +import qualified Control.Monad.Fail as Fail import Data.List.Extra (nubSort) import qualified Data.Text as T import qualified Data.Text.IO as T @@ -24,11 +25,13 @@ tagsmode = hledgerCommandMode hiddenflags ([], Just $ argsFlag "[TAGREGEX [QUERY...]]") +tags :: CliOpts -> Journal -> IO () tags CliOpts{rawopts_=rawopts,reportopts_=ropts} j = do d <- getCurrentDay let args = listofstringopt "args" rawopts - mtagpat = headMay args + mtagpat <- mapM (either Fail.fail pure . toRegexCI_) $ headMay args + let queryargs = drop 1 args values = boolopt "values" rawopts parsed = boolopt "parsed" rawopts @@ -39,7 +42,7 @@ tags CliOpts{rawopts_=rawopts,reportopts_=ropts} j = do (if parsed then id else nubSort) [ r | (t,v) <- concatMap transactionAllTags txns - , maybe True (`regexMatchesCI` T.unpack t) mtagpat + , maybe True (`match` T.unpack t) mtagpat , let r = if values then v else t , not (values && T.null v && not empty) ] diff --git a/hledger/Hledger/Cli/Main.hs b/hledger/Hledger/Cli/Main.hs index e7203a0ed..e9fc21965 100644 --- a/hledger/Hledger/Cli/Main.hs +++ b/hledger/Hledger/Cli/Main.hs @@ -82,14 +82,14 @@ mainmode addons = defMode { [detailedversionflag] -- ++ inputflags -- included here so they'll not raise a confusing error if present with no COMMAND } - ,modeHelpSuffix = map (regexReplace "PROGNAME" progname) [ - "Examples:" - ,"PROGNAME list commands" - ,"PROGNAME CMD [--] [OPTS] [ARGS] run a command (use -- with addon commands)" - ,"PROGNAME-CMD [OPTS] [ARGS] or run addon commands directly" - ,"PROGNAME -h show general usage" - ,"PROGNAME CMD -h show command usage" - ,"PROGNAME help [MANUAL] show any of the hledger manuals in various formats" + ,modeHelpSuffix = "Examples:" : + map (progname ++) [ + " list commands" + ," CMD [--] [OPTS] [ARGS] run a command (use -- with addon commands)" + ,"-CMD [OPTS] [ARGS] or run addon commands directly" + ," -h show general usage" + ," CMD -h show command usage" + ," help [MANUAL] show any of the hledger manuals in various formats" ] }