From ccd6fdd7b903a2eaed71f4fc03c994db91c7936f Mon Sep 17 00:00:00 2001 From: Stephen Morgan Date: Sat, 15 Aug 2020 19:31:56 +1000 Subject: [PATCH 01/11] lib: Remove unused Tree functions. --- hledger-lib/Hledger/Utils/Tree.hs | 71 +++---------------------------- 1 file changed, 5 insertions(+), 66 deletions(-) diff --git a/hledger-lib/Hledger/Utils/Tree.hs b/hledger-lib/Hledger/Utils/Tree.hs index 77941eb19..d3bd51f1e 100644 --- a/hledger-lib/Hledger/Utils/Tree.hs +++ b/hledger-lib/Hledger/Utils/Tree.hs @@ -1,77 +1,18 @@ -module Hledger.Utils.Tree where +module Hledger.Utils.Tree +( FastTree(..) +, treeFromPaths +) where -- import Data.Char import Data.List (foldl') import qualified Data.Map as M -import Data.Tree --- import Text.Megaparsec --- import Text.Printf - -import Hledger.Utils.Regex --- import Hledger.Utils.UTF8IOCompat (error') - --- standard tree helpers - -root = rootLabel -subs = subForest -branches = subForest - --- | List just the leaf nodes of a tree -leaves :: Tree a -> [a] -leaves (Node v []) = [v] -leaves (Node _ branches) = concatMap leaves branches - --- | get the sub-tree rooted at the first (left-most, depth-first) occurrence --- of the specified node value -subtreeat :: Eq a => a -> Tree a -> Maybe (Tree a) -subtreeat v t - | root t == v = Just t - | otherwise = subtreeinforest v $ subs t - --- | get the sub-tree for the specified node value in the first tree in --- forest in which it occurs. -subtreeinforest :: Eq a => a -> [Tree a] -> Maybe (Tree a) -subtreeinforest _ [] = Nothing -subtreeinforest v (t:ts) = case (subtreeat v t) of - Just t' -> Just t' - Nothing -> subtreeinforest v ts - --- | remove all nodes past a certain depth -treeprune :: Int -> Tree a -> Tree a -treeprune 0 t = Node (root t) [] -treeprune d t = Node (root t) (map (treeprune $ d-1) $ branches t) - --- | apply f to all tree nodes -treemap :: (a -> b) -> Tree a -> Tree b -treemap f t = Node (f $ root t) (map (treemap f) $ branches t) - --- | remove all subtrees whose nodes do not fulfill predicate -treefilter :: (a -> Bool) -> Tree a -> Tree a -treefilter f t = Node - (root t) - (map (treefilter f) $ filter (treeany f) $ branches t) - --- | is predicate true in any node of tree ? -treeany :: (a -> Bool) -> Tree a -> Bool -treeany f t = f (root t) || any (treeany f) (branches t) - --- treedrop -- remove the leaves which do fulfill predicate. --- treedropall -- do this repeatedly. - --- | show a compact ascii representation of a tree -showtree :: Show a => Tree a -> String -showtree = unlines . filter (regexMatches "[^ \\|]") . lines . drawTree . treemap show - --- | show a compact ascii representation of a forest -showforest :: Show a => Forest a -> String -showforest = concatMap showtree - -- | An efficient-to-build tree suggested by Cale Gibbard, probably -- better than accountNameTreeFrom. newtype FastTree a = T (M.Map a (FastTree a)) deriving (Show, Eq, Ord) +emptyTree :: FastTree a emptyTree = T M.empty mergeTrees :: (Ord a) => FastTree a -> FastTree a -> FastTree a @@ -83,5 +24,3 @@ treeFromPath (x:xs) = T (M.singleton x (treeFromPath xs)) treeFromPaths :: (Ord a) => [[a]] -> FastTree a treeFromPaths = foldl' mergeTrees emptyTree . map treeFromPath - - From e5371d5a6a2cbe6661111f57e231a668aafe5355 Mon Sep 17 00:00:00 2001 From: Stephen Morgan Date: Sat, 15 Aug 2020 19:14:27 +1000 Subject: [PATCH 02/11] lib,cli,ui,web: Make Regexp a wrapper for Regex. --- hledger-lib/Hledger/Data/Account.hs | 5 +- hledger-lib/Hledger/Data/AccountName.hs | 16 +- hledger-lib/Hledger/Data/Journal.hs | 51 +-- hledger-lib/Hledger/Data/Ledger.hs | 7 - hledger-lib/Hledger/Data/Posting.hs | 2 +- hledger-lib/Hledger/Data/Types.hs | 6 +- hledger-lib/Hledger/Query.hs | 328 +++++++++--------- hledger-lib/Hledger/Read/Common.hs | 2 +- hledger-lib/Hledger/Read/CsvReader.hs | 50 +-- hledger-lib/Hledger/Read/JournalReader.hs | 4 +- hledger-lib/Hledger/Reports/EntriesReport.hs | 2 +- hledger-lib/Hledger/Reports/PostingsReport.hs | 6 +- hledger-lib/Hledger/Reports/ReportOptions.hs | 17 +- hledger-lib/Hledger/Utils/Regex.hs | 247 ++++++------- hledger-lib/Hledger/Utils/String.hs | 6 +- hledger-ui/Hledger/UI/AccountsScreen.hs | 2 +- hledger-ui/Hledger/UI/Main.hs | 2 +- hledger-ui/Hledger/UI/RegisterScreen.hs | 2 +- hledger-web/Hledger/Web/Widget/AddForm.hs | 2 +- hledger-web/Hledger/Web/Widget/Common.hs | 2 +- hledger/Hledger/Cli/Commands.hs | 30 +- hledger/Hledger/Cli/Commands/Aregister.hs | 13 +- hledger/Hledger/Cli/Commands/Files.hs | 4 +- hledger/Hledger/Cli/Commands/Tags.hs | 7 +- hledger/Hledger/Cli/Main.hs | 16 +- 25 files changed, 389 insertions(+), 440 deletions(-) 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" ] } From e3b2c94353ded9c5fa9fc1fda3ba9f7c599104b0 Mon Sep 17 00:00:00 2001 From: Stephen Morgan Date: Mon, 17 Aug 2020 21:55:43 +1000 Subject: [PATCH 03/11] lib: Remove unneeded total Query code. --- hledger-lib/Hledger/Query.hs | 97 ------------------------------ hledger-lib/Hledger/Utils/Regex.hs | 1 - 2 files changed, 98 deletions(-) diff --git a/hledger-lib/Hledger/Query.hs b/hledger-lib/Hledger/Query.hs index ca7d52c8d..701cf8069 100644 --- a/hledger-lib/Hledger/Query.hs +++ b/hledger-lib/Hledger/Query.hs @@ -579,19 +579,6 @@ 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. - -- 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 @@ -600,13 +587,6 @@ matchesCommodity :: Query -> CommoditySymbol -> Bool 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. - -- 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 matchesAmount (Not q) a = not $ q `matchesAmount` a @@ -618,19 +598,6 @@ matchesAmount (Amt ord n) a = compareAmount ord n a matchesAmount (Sym r) a = matchesCommodity (Sym r) (acommodity a) matchesAmount _ _ = True --- | Total version of matchesAmount, returning any error from a --- malformed regular expression in the query. - -- 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. @@ -677,32 +644,6 @@ matchesPosting (Tag n v) p = case (reString n, v) of ("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. - -- -- 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 matchesTransaction (Not q) t = not $ q `matchesTransaction` t @@ -726,31 +667,6 @@ matchesTransaction (Tag n v) t = case (reString n, v) of ("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. - -- 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 (matches namepat valuepat) @@ -768,19 +684,6 @@ matchesPriceDirective q@(Sym _) p = matchesCommodity q (pdcommodity p) matchesPriceDirective (Date span) p = spanContainsDate span (pddate p) matchesPriceDirective _ _ = True --- | Total version of matchesPriceDirective, returning any error from --- a malformed regular expression in the query. - -- 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 diff --git a/hledger-lib/Hledger/Utils/Regex.hs b/hledger-lib/Hledger/Utils/Regex.hs index 3ffa35105..d21a88358 100644 --- a/hledger-lib/Hledger/Utils/Regex.hs +++ b/hledger-lib/Hledger/Utils/Regex.hs @@ -215,7 +215,6 @@ replaceRegexUnmemo_ re repl s = foldM (replaceMatch_ repl) s (reverse $ match (r -- The replacement text: the replacement pattern with all -- numeric backreferences replaced by the appropriate groups -- from this match. Or an error message. - -- FIXME: Use makeRegex instead of toRegex_ erepl = replaceAllByM backrefRegex (lookupMatchGroup_ matchgroups) replpat where -- Given some match groups and a numeric backreference, From 01f5a92761f7f95a104a2ada1d1cd36885a6ab5c Mon Sep 17 00:00:00 2001 From: Stephen Morgan Date: Tue, 18 Aug 2020 11:32:15 +1000 Subject: [PATCH 04/11] lib: Improve Read and Show instances for Regexp, get rid of custom show instance for Query. --- hledger-lib/Hledger/Query.hs | 27 +++------------------------ hledger-lib/Hledger/Utils/Regex.hs | 17 +++++++++++------ 2 files changed, 14 insertions(+), 30 deletions(-) diff --git a/hledger-lib/Hledger/Query.hs b/hledger-lib/Hledger/Query.hs index 701cf8069..7968ea85c 100644 --- a/hledger-lib/Hledger/Query.hs +++ b/hledger-lib/Hledger/Query.hs @@ -105,7 +105,7 @@ data Query = Any -- ^ always match -- and sometimes like a query option (for controlling display) | Tag Regexp (Maybe Regexp) -- ^ match if a tag's name, and optionally its value, is matched by these respective regexps -- matching the regexp if provided, exists - deriving (Eq,Data,Typeable) + deriving (Eq,Show,Data,Typeable) -- | Construct a payee tag payeeTag :: Maybe String -> Either RegexError Query @@ -115,26 +115,6 @@ payeeTag = liftA2 Tag (toRegexCI_ "payee") . maybe (pure Nothing) (fmap Just . t 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" - show None = "None" - show (Not q) = "Not (" ++ show q ++ ")" - show (Or qs) = "Or (" ++ show qs ++ ")" - show (And qs) = "And (" ++ show qs ++ ")" - show (Code r) = "Code " ++ show r - show (Desc r) = "Desc " ++ show r - show (Acct r) = "Acct " ++ show r - show (Date ds) = "Date (" ++ show ds ++ ")" - show (Date2 ds) = "Date2 (" ++ show ds ++ ")" - show (StatusQ b) = "StatusQ " ++ show b - show (Real b) = "Real " ++ show b - show (Amt ord qty) = "Amt " ++ show ord ++ " " ++ show qty - show (Sym r) = "Sym " ++ show r - show (Empty b) = "Empty " ++ show b - show (Depth n) = "Depth " ++ show n - show (Tag s ms) = "Tag " ++ show s ++ " (" ++ show ms ++ ")" - -- | A more expressive Ord, used for amt: queries. The Abs* variants -- compare with the absolute value of a number, ignoring sign. data OrdPlus = Lt | LtEq | Gt | GtEq | Eq | AbsLt | AbsLtEq | AbsGt | AbsGtEq | AbsEq @@ -190,11 +170,10 @@ data QueryOpt = QueryOptInAcctOnly AccountName -- ^ show an account register fo -- 4. then all terms are AND'd together -- -- >>> parseQuery nulldate "expenses:dining out" --- Right (Or ([Acct "expenses:dining",Acct "out"]),[]) +-- Right (Or [Acct (RegexpCI "expenses:dining"),Acct (RegexpCI "out")],[]) -- -- >>> parseQuery nulldate "\"expenses:dining out\"" --- Right (Acct "expenses:dining out",[]) --- +-- Right (Acct (RegexpCI "expenses:dining out"),[]) parseQuery :: Day -> T.Text -> Either String (Query,[QueryOpt]) parseQuery d s = do let termstrs = words'' prefixes s diff --git a/hledger-lib/Hledger/Utils/Regex.hs b/hledger-lib/Hledger/Utils/Regex.hs index d21a88358..ba12cb896 100644 --- a/hledger-lib/Hledger/Utils/Regex.hs +++ b/hledger-lib/Hledger/Utils/Regex.hs @@ -76,7 +76,6 @@ module Hledger.Utils.Regex ( ) where -import Control.Arrow (first) import Control.Monad (foldM) import Data.Aeson (ToJSON(..), Value(String)) import Data.Array ((!), elems, indices) @@ -111,13 +110,19 @@ instance Ord Regexp where 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 + showsPrec d r = showParen (d > app_prec) $ reCons . showsPrec (app_prec+1) (reString r) + where app_prec = 10 + reCons = case r of Regexp _ _ -> showString "Regexp " + RegexpCI _ _ -> showString "RegexpCI " 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 + readsPrec d r = readParen (d > app_prec) (\r -> [(toRegexCI' m,t) | + ("RegexCI",s) <- lex r, + (m,t) <- readsPrec (app_prec+1) s]) r + ++ readParen (d > app_prec) (\r -> [(toRegex' m, t) | + ("Regex",s) <- lex r, + (m,t) <- readsPrec (app_prec+1) s]) r + where app_prec = 10 instance Data Regexp where toConstr _ = error' "No toConstr for Regex" From af31d6e140d3ea2a8c215f42319c35797aff834d Mon Sep 17 00:00:00 2001 From: Stephen Morgan Date: Mon, 31 Aug 2020 14:56:38 +1000 Subject: [PATCH 05/11] lib,cli,ui: Remove redundant Typeable and Data instances. Also add some explicit import lists. --- hledger-lib/Hledger/Data/RawOptions.hs | 12 ++-- hledger-lib/Hledger/Data/Types.hs | 63 +++++++++---------- hledger-lib/Hledger/Data/Valuation.hs | 5 +- hledger-lib/Hledger/Query.hs | 18 +++--- hledger-lib/Hledger/Read/Common.hs | 22 +++---- hledger-lib/Hledger/Reports.hs | 2 +- .../Reports/AccountTransactionsReport.hs | 2 +- hledger-lib/Hledger/Reports/EntriesReport.hs | 2 +- hledger-lib/Hledger/Reports/PostingsReport.hs | 1 - hledger-lib/Hledger/Reports/ReportOptions.hs | 17 +++-- .../Hledger/Reports/TransactionsReport.hs | 2 +- hledger-lib/Hledger/Utils/Regex.hs | 7 --- hledger-ui/Hledger/UI/UIOptions.hs | 1 - hledger/Hledger/Cli/CliOptions.hs | 4 +- hledger/Hledger/Cli/Commands/Add.hs | 9 ++- 15 files changed, 72 insertions(+), 95 deletions(-) diff --git a/hledger-lib/Hledger/Data/RawOptions.hs b/hledger-lib/Hledger/Data/RawOptions.hs index e2c46deea..0c5a55086 100644 --- a/hledger-lib/Hledger/Data/RawOptions.hs +++ b/hledger-lib/Hledger/Data/RawOptions.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} - {-| hledger's cmdargs modes parse command-line arguments to an @@ -28,17 +26,16 @@ module Hledger.Data.RawOptions ( ) where -import Data.Maybe -import Data.Data -import Data.Default -import Safe +import Data.Maybe (fromMaybe, isJust, mapMaybe) +import Data.Default (Default(..)) +import Safe (headMay, lastMay, readDef) import Hledger.Utils -- | The result of running cmdargs: an association list of option names to string values. newtype RawOpts = RawOpts { unRawOpts :: [(String,String)] } - deriving (Show, Data, Typeable) + deriving (Show) instance Default RawOpts where def = RawOpts [] @@ -61,6 +58,7 @@ boolopt = inRawOpts -- for which the given predicate returns a Just value. -- Useful for exclusive choice flags like --daily|--weekly|--quarterly... -- +-- >>> import Safe (readMay) -- >>> choiceopt Just (RawOpts [("a",""), ("b",""), ("c","")]) -- Just "c" -- >>> choiceopt (const Nothing) (RawOpts [("a","")]) diff --git a/hledger-lib/Hledger/Data/Types.hs b/hledger-lib/Hledger/Data/Types.hs index d08dacc02..7b7f266b4 100644 --- a/hledger-lib/Hledger/Data/Types.hs +++ b/hledger-lib/Hledger/Data/Types.hs @@ -17,7 +17,6 @@ For more detailed documentation on each type, see the corresponding modules. -} -- {-# LANGUAGE DeriveAnyClass #-} -- https://hackage.haskell.org/package/deepseq-1.4.4.0/docs/Control-DeepSeq.html#v:rnf -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} @@ -30,7 +29,6 @@ where import GHC.Generics (Generic) import Control.DeepSeq (NFData) -import Data.Data import Data.Decimal import Data.Default import Data.Functor (($>)) @@ -77,7 +75,7 @@ data SmartInterval = Day | Week | Month | Quarter | Year deriving (Show) data WhichDate = PrimaryDate | SecondaryDate deriving (Eq,Show) -data DateSpan = DateSpan (Maybe Day) (Maybe Day) deriving (Eq,Ord,Data,Generic,Typeable) +data DateSpan = DateSpan (Maybe Day) (Maybe Day) deriving (Eq,Ord,Generic) instance Default DateSpan where def = DateSpan Nothing Nothing @@ -105,7 +103,7 @@ data Period = | PeriodFrom Day | PeriodTo Day | PeriodAll - deriving (Eq,Ord,Show,Data,Generic,Typeable) + deriving (Eq,Ord,Show,Generic) instance Default Period where def = PeriodAll @@ -116,7 +114,7 @@ instance Default Period where def = PeriodAll -- MonthLong -- QuarterLong -- YearLong --- deriving (Eq,Ord,Show,Data,Generic,Typeable) +-- deriving (Eq,Ord,Show,Generic) -- Ways in which a period can be divided into subperiods. data Interval = @@ -133,7 +131,7 @@ data Interval = -- WeekOfYear Int -- MonthOfYear Int -- QuarterOfYear Int - deriving (Eq,Show,Ord,Data,Generic,Typeable) + deriving (Eq,Show,Ord,Generic) instance Default Interval where def = NoInterval @@ -148,7 +146,7 @@ data AccountType = | Revenue | Expense | Cash -- ^ a subtype of Asset - liquid assets to show in cashflow report - deriving (Show,Eq,Ord,Data,Generic) + deriving (Show,Eq,Ord,Generic) instance NFData AccountType @@ -164,17 +162,16 @@ instance NFData AccountType data AccountAlias = BasicAlias AccountName AccountName | RegexAlias Regexp Replacement - deriving (Eq, Read, Show, Ord, Data, Generic, Typeable) + deriving (Eq, Read, Show, Ord, Generic) -- instance NFData AccountAlias -data Side = L | R deriving (Eq,Show,Read,Ord,Typeable,Data,Generic) +data Side = L | R deriving (Eq,Show,Read,Ord,Generic) instance NFData Side -- | The basic numeric type used in amounts. type Quantity = Decimal -deriving instance Data Quantity -- The following is for hledger-web, and requires blaze-markup. -- Doing it here avoids needing a matching flag on the hledger-web package. instance ToMarkup Quantity @@ -185,7 +182,7 @@ instance ToMarkup Quantity -- commodity, as recorded in the journal entry eg with @ or @@. -- Docs call this "transaction price". The amount is always positive. data AmountPrice = UnitPrice Amount | TotalPrice Amount - deriving (Eq,Ord,Typeable,Data,Generic,Show) + deriving (Eq,Ord,Generic,Show) instance NFData AmountPrice @@ -196,7 +193,7 @@ data AmountStyle = AmountStyle { asprecision :: !AmountPrecision, -- ^ number of digits displayed after the decimal point asdecimalpoint :: Maybe Char, -- ^ character used as decimal point: period or comma. Nothing means "unspecified, use default" asdigitgroups :: Maybe DigitGroupStyle -- ^ style for displaying digit groups, if any -} deriving (Eq,Ord,Read,Typeable,Data,Generic) +} deriving (Eq,Ord,Read,Generic) instance NFData AmountStyle @@ -209,7 +206,7 @@ instance Show AmountStyle where (show asdecimalpoint) (show asdigitgroups) -data AmountPrecision = Precision !Word8 | NaturalPrecision deriving (Eq,Ord,Read,Show,Typeable,Data,Generic) +data AmountPrecision = Precision !Word8 | NaturalPrecision deriving (Eq,Ord,Read,Show,Generic) instance NFData AmountPrecision @@ -220,7 +217,7 @@ instance NFData AmountPrecision -- the decimal point. The last group size is assumed to repeat. Eg, -- comma between thousands is DigitGroups ',' [3]. data DigitGroupStyle = DigitGroups Char [Word8] - deriving (Eq,Ord,Read,Show,Typeable,Data,Generic) + deriving (Eq,Ord,Read,Show,Generic) instance NFData DigitGroupStyle @@ -229,7 +226,7 @@ type CommoditySymbol = Text data Commodity = Commodity { csymbol :: CommoditySymbol, cformat :: Maybe AmountStyle - } deriving (Show,Eq,Data,Generic) --,Ord,Typeable,Data,Generic) + } deriving (Show,Eq,Generic) --,Ord) instance NFData Commodity @@ -240,16 +237,16 @@ data Amount = Amount { -- in a TMPostingRule. In a regular Posting, should always be false. astyle :: AmountStyle, aprice :: Maybe AmountPrice -- ^ the (fixed, transaction-specific) price for this amount, if any - } deriving (Eq,Ord,Typeable,Data,Generic,Show) + } deriving (Eq,Ord,Generic,Show) instance NFData Amount -newtype MixedAmount = Mixed [Amount] deriving (Eq,Ord,Typeable,Data,Generic,Show) +newtype MixedAmount = Mixed [Amount] deriving (Eq,Ord,Generic,Show) instance NFData MixedAmount data PostingType = RegularPosting | VirtualPosting | BalancedVirtualPosting - deriving (Eq,Show,Typeable,Data,Generic) + deriving (Eq,Show,Generic) instance NFData PostingType @@ -261,7 +258,7 @@ type DateTag = (TagName, Day) -- | The status of a transaction or posting, recorded with a status mark -- (nothing, !, or *). What these mean is ultimately user defined. data Status = Unmarked | Pending | Cleared - deriving (Eq,Ord,Bounded,Enum,Typeable,Data,Generic) + deriving (Eq,Ord,Bounded,Enum,Generic) instance NFData Status @@ -312,7 +309,7 @@ data BalanceAssertion = BalanceAssertion { batotal :: Bool, -- ^ disallow additional non-asserted commodities ? bainclusive :: Bool, -- ^ include subaccounts when calculating the actual balance ? baposition :: GenericSourcePos -- ^ the assertion's file position, for error reporting - } deriving (Eq,Typeable,Data,Generic,Show) + } deriving (Eq,Generic,Show) instance NFData BalanceAssertion @@ -333,7 +330,7 @@ data Posting = Posting { -- (eg its amount or price was inferred, or the account name was -- changed by a pivot or budget report), this references the original -- untransformed posting (which will have Nothing in this field). - } deriving (Typeable,Data,Generic) + } deriving (Generic) instance NFData Posting @@ -363,7 +360,7 @@ instance Show Posting where -- | The position of parse errors (eg), like parsec's SourcePos but generic. data GenericSourcePos = GenericSourcePos FilePath Int Int -- ^ file path, 1-based line number and 1-based column number. | JournalSourcePos FilePath (Int, Int) -- ^ file path, inclusive range of 1-based line numbers (first, last). - deriving (Eq, Read, Show, Ord, Data, Generic, Typeable) + deriving (Eq, Read, Show, Ord, Generic) instance NFData GenericSourcePos @@ -383,7 +380,7 @@ data Transaction = Transaction { tcomment :: Text, -- ^ this transaction's comment lines, as a single non-indented multi-line string ttags :: [Tag], -- ^ tag names and values, extracted from the comment tpostings :: [Posting] -- ^ this transaction's postings - } deriving (Eq,Typeable,Data,Generic,Show) + } deriving (Eq,Generic,Show) instance NFData Transaction @@ -395,7 +392,7 @@ instance NFData Transaction data TransactionModifier = TransactionModifier { tmquerytxt :: Text, tmpostingrules :: [TMPostingRule] - } deriving (Eq,Typeable,Data,Generic,Show) + } deriving (Eq,Generic,Show) instance NFData TransactionModifier @@ -422,7 +419,7 @@ data PeriodicTransaction = PeriodicTransaction { ptcomment :: Text, pttags :: [Tag], ptpostings :: [Posting] - } deriving (Eq,Typeable,Data,Generic) -- , Show in PeriodicTransaction.hs + } deriving (Eq,Generic) -- , Show in PeriodicTransaction.hs nullperiodictransaction = PeriodicTransaction{ ptperiodexpr = "" @@ -438,7 +435,7 @@ nullperiodictransaction = PeriodicTransaction{ instance NFData PeriodicTransaction -data TimeclockCode = SetBalance | SetRequiredHours | In | Out | FinalOut deriving (Eq,Ord,Typeable,Data,Generic) +data TimeclockCode = SetBalance | SetRequiredHours | In | Out | FinalOut deriving (Eq,Ord,Generic) instance NFData TimeclockCode @@ -448,7 +445,7 @@ data TimeclockEntry = TimeclockEntry { tldatetime :: LocalTime, tlaccount :: AccountName, tldescription :: Text - } deriving (Eq,Ord,Typeable,Data,Generic) + } deriving (Eq,Ord,Generic) instance NFData TimeclockEntry @@ -459,7 +456,7 @@ data PriceDirective = PriceDirective { pddate :: Day ,pdcommodity :: CommoditySymbol ,pdamount :: Amount - } deriving (Eq,Ord,Typeable,Data,Generic,Show) + } deriving (Eq,Ord,Generic,Show) -- Show instance derived in Amount.hs (XXX why ?) instance NFData PriceDirective @@ -471,7 +468,7 @@ data MarketPrice = MarketPrice { ,mpfrom :: CommoditySymbol -- ^ The commodity being converted from. ,mpto :: CommoditySymbol -- ^ The commodity being converted to. ,mprate :: Quantity -- ^ One unit of the "from" commodity is worth this quantity of the "to" commodity. - } deriving (Eq,Ord,Typeable,Data,Generic) + } deriving (Eq,Ord,Generic) -- Show instance derived in Amount.hs (XXX why ?) instance NFData MarketPrice @@ -514,8 +511,6 @@ data Journal = Journal { ,jlastreadtime :: ClockTime -- ^ when this journal was last read from its file(s) } deriving (Eq, Generic) -deriving instance Data ClockTime -deriving instance Typeable ClockTime deriving instance Generic ClockTime instance NFData ClockTime -- instance NFData Journal @@ -535,7 +530,7 @@ data AccountDeclarationInfo = AccountDeclarationInfo { ,aditags :: [Tag] -- ^ tags extracted from the account comment, if any ,adideclarationorder :: Int -- ^ the order in which this account was declared, -- relative to other account declarations, during parsing (1..) -} deriving (Eq,Show,Data,Generic) +} deriving (Eq,Show,Generic) instance NFData AccountDeclarationInfo @@ -558,14 +553,14 @@ data Account = Account { ,anumpostings :: Int -- ^ the number of postings to this account ,aebalance :: MixedAmount -- ^ this account's balance, excluding subaccounts ,aibalance :: MixedAmount -- ^ this account's balance, including subaccounts - } deriving (Typeable, Data, Generic) + } deriving (Generic) -- | Whether an account's balance is normally a positive number (in -- accounting terms, a debit balance) or a negative number (credit balance). -- Assets and expenses are normally positive (debit), while liabilities, equity -- and income are normally negative (credit). -- https://en.wikipedia.org/wiki/Normal_balance -data NormalSign = NormallyPositive | NormallyNegative deriving (Show, Data, Eq) +data NormalSign = NormallyPositive | NormallyNegative deriving (Show, Eq) -- | A Ledger has the journal it derives from, and the accounts -- derived from that. Accounts are accessible both list-wise and diff --git a/hledger-lib/Hledger/Data/Valuation.hs b/hledger-lib/Hledger/Data/Valuation.hs index 03fafd24e..506beeb89 100644 --- a/hledger-lib/Hledger/Data/Valuation.hs +++ b/hledger-lib/Hledger/Data/Valuation.hs @@ -9,7 +9,7 @@ looking up historical market prices (exchange rates) between commodities. {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} module Hledger.Data.Valuation ( ValuationType(..) @@ -29,7 +29,6 @@ where import Control.Applicative ((<|>)) import Control.DeepSeq (NFData) -import Data.Data import Data.Decimal (roundTo) import Data.Function ((&), on) import Data.Graph.Inductive (Gr, Node, NodeMap, mkMapGraph, mkNode, lab, out, sp) @@ -60,7 +59,7 @@ data ValuationType = | AtNow (Maybe CommoditySymbol) -- ^ convert to default or given valuation commodity, using current market prices | AtDate Day (Maybe CommoditySymbol) -- ^ convert to default or given valuation commodity, using market prices on some date | AtDefault (Maybe CommoditySymbol) -- ^ works like AtNow in single period reports, like AtEnd in multiperiod reports - deriving (Show,Data,Eq) -- Typeable + deriving (Show,Eq) -- | A snapshot of the known exchange rates between commodity pairs at a given date, -- as a graph allowing fast lookup and path finding, along with some helper data. diff --git a/hledger-lib/Hledger/Query.hs b/hledger-lib/Hledger/Query.hs index 7968ea85c..c4ef59b7e 100644 --- a/hledger-lib/Hledger/Query.hs +++ b/hledger-lib/Hledger/Query.hs @@ -10,7 +10,6 @@ transactions..) by various criteria, and a SimpleTextParser for query expressio {-# OPTIONS_GHC -Wno-warnings-deprecations #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} @@ -60,18 +59,17 @@ module Hledger.Query ( where import Control.Applicative ((<|>), liftA2, many, optional) -import Data.Data -import Data.Either -import Data.List -import Data.Maybe +import Data.Either (partitionEithers) +import Data.List (partition) +import Data.Maybe (fromMaybe, isJust, mapMaybe) #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid ((<>)) #endif import qualified Data.Text as T -import Data.Time.Calendar +import Data.Time.Calendar (Day, fromGregorian ) import Safe (readDef, readMay, maximumByMay, maximumMay, minimumMay) import Text.Megaparsec (between, noneOf, sepBy) -import Text.Megaparsec.Char +import Text.Megaparsec.Char (char, string) import Hledger.Utils hiding (words') import Hledger.Data.Types @@ -105,7 +103,7 @@ data Query = Any -- ^ always match -- and sometimes like a query option (for controlling display) | Tag Regexp (Maybe Regexp) -- ^ match if a tag's name, and optionally its value, is matched by these respective regexps -- matching the regexp if provided, exists - deriving (Eq,Show,Data,Typeable) + deriving (Eq,Show) -- | Construct a payee tag payeeTag :: Maybe String -> Either RegexError Query @@ -118,14 +116,14 @@ noteTag = liftA2 Tag (toRegexCI_ "note") . maybe (pure Nothing) (fmap Just . toR -- | A more expressive Ord, used for amt: queries. The Abs* variants -- compare with the absolute value of a number, ignoring sign. data OrdPlus = Lt | LtEq | Gt | GtEq | Eq | AbsLt | AbsLtEq | AbsGt | AbsGtEq | AbsEq - deriving (Show,Eq,Data,Typeable) + deriving (Show,Eq) -- | A query option changes a query's/report's behaviour and output in some way. data QueryOpt = QueryOptInAcctOnly AccountName -- ^ show an account register focussed on this account | QueryOptInAcct AccountName -- ^ as above but include sub-accounts in the account register -- | QueryOptCostBasis -- ^ show amounts converted to cost where possible -- | QueryOptDate2 -- ^ show secondary dates instead of primary dates - deriving (Show, Eq, Data, Typeable) + deriving (Show, Eq) -- parsing diff --git a/hledger-lib/Hledger/Read/Common.hs b/hledger-lib/Hledger/Read/Common.hs index 7e10af874..4ff896627 100644 --- a/hledger-lib/Hledger/Read/Common.hs +++ b/hledger-lib/Hledger/Read/Common.hs @@ -14,7 +14,6 @@ Some of these might belong in Hledger.Read.JournalReader or Hledger.Read. --- ** language {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -116,32 +115,33 @@ where --- ** imports import Prelude () import "base-compat-batteries" Prelude.Compat hiding (fail, readFile) +import Control.Applicative.Permutations (runPermutation, toPermutationWithDefault) import qualified "base-compat-batteries" Control.Monad.Fail.Compat as Fail (fail) import Control.Monad.Except (ExceptT(..), runExceptT, throwError) import Control.Monad.State.Strict hiding (fail) import Data.Bifunctor (bimap, second) -import Data.Char -import Data.Data +import Data.Char (digitToInt, isDigit, isSpace) import Data.Decimal (DecimalRaw (Decimal), Decimal) -import Data.Default +import Data.Default (Default(..)) import Data.Function ((&)) -import Data.Functor.Identity +import Data.Functor.Identity (Identity) import "base-compat-batteries" Data.List.Compat import Data.List.NonEmpty (NonEmpty(..)) -import Data.Maybe +import Data.Maybe (catMaybes, fromMaybe, isJust, listToMaybe) import qualified Data.Map as M import qualified Data.Semigroup as Sem import Data.Text (Text) import qualified Data.Text as T -import Data.Time.Calendar -import Data.Time.LocalTime +import Data.Time.Calendar (Day, fromGregorianValid, toGregorian) +import Data.Time.LocalTime (LocalTime(..), TimeOfDay(..)) import Data.Word (Word8) import System.Time (getClockTime) import Text.Megaparsec -import Text.Megaparsec.Char +import Text.Megaparsec.Char (char, char', digitChar, newline, string) import Text.Megaparsec.Char.Lexer (decimal) import Text.Megaparsec.Custom -import Control.Applicative.Permutations + (FinalParseError, attachSource, customErrorBundlePretty, + finalErrorBundlePretty, parseErrorAt, parseErrorAtRegion) import Hledger.Data import Hledger.Utils hiding (match) @@ -194,7 +194,7 @@ data InputOpts = InputOpts { ,new_save_ :: Bool -- ^ save latest new transactions state for next time ,pivot_ :: String -- ^ use the given field's value as the account name ,auto_ :: Bool -- ^ generate automatic postings when journal is parsed - } deriving (Show, Data) --, Typeable) + } deriving (Show) instance Default InputOpts where def = definputopts diff --git a/hledger-lib/Hledger/Reports.hs b/hledger-lib/Hledger/Reports.hs index c8b4f17b9..434da6fda 100644 --- a/hledger-lib/Hledger/Reports.hs +++ b/hledger-lib/Hledger/Reports.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, RecordWildCards, DeriveDataTypeable, FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings, RecordWildCards, FlexibleInstances #-} {-| Generate several common kinds of report from a journal, as \"*Report\" - diff --git a/hledger-lib/Hledger/Reports/AccountTransactionsReport.hs b/hledger-lib/Hledger/Reports/AccountTransactionsReport.hs index 461db5919..5aa9241b0 100644 --- a/hledger-lib/Hledger/Reports/AccountTransactionsReport.hs +++ b/hledger-lib/Hledger/Reports/AccountTransactionsReport.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, RecordWildCards, DeriveDataTypeable, FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings, RecordWildCards, FlexibleInstances #-} {-| An account-centric transactions report. diff --git a/hledger-lib/Hledger/Reports/EntriesReport.hs b/hledger-lib/Hledger/Reports/EntriesReport.hs index fb1c15b72..25d86c11b 100644 --- a/hledger-lib/Hledger/Reports/EntriesReport.hs +++ b/hledger-lib/Hledger/Reports/EntriesReport.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, RecordWildCards, DeriveDataTypeable, FlexibleInstances, ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings, RecordWildCards, FlexibleInstances, ScopedTypeVariables #-} {-| Journal entries report, used by the print command. diff --git a/hledger-lib/Hledger/Reports/PostingsReport.hs b/hledger-lib/Hledger/Reports/PostingsReport.hs index bb9bccc5a..dadb7b699 100644 --- a/hledger-lib/Hledger/Reports/PostingsReport.hs +++ b/hledger-lib/Hledger/Reports/PostingsReport.hs @@ -4,7 +4,6 @@ Postings report, used by the register command. -} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} diff --git a/hledger-lib/Hledger/Reports/ReportOptions.hs b/hledger-lib/Hledger/Reports/ReportOptions.hs index 3436d24f5..2ce27dd20 100644 --- a/hledger-lib/Hledger/Reports/ReportOptions.hs +++ b/hledger-lib/Hledger/Reports/ReportOptions.hs @@ -4,7 +4,6 @@ Options common to most hledger reports. -} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -49,14 +48,12 @@ module Hledger.Reports.ReportOptions ( where import Control.Applicative ((<|>)) -import Data.Data (Data) import Data.List.Extra (nubSort) -import Data.Maybe +import Data.Maybe (fromMaybe, isJust) import qualified Data.Text as T -import Data.Typeable (Typeable) -import Data.Time.Calendar -import Data.Default -import Safe +import Data.Time.Calendar (Day, addDays, fromGregorian) +import Data.Default (Default(..)) +import Safe (lastDef, lastMay) import System.Console.ANSI (hSupportsANSIColor) import System.Environment (lookupEnv) @@ -76,12 +73,12 @@ data BalanceType = PeriodChange -- ^ The change of balance in each period. | HistoricalBalance -- ^ The historical ending balance, including the effect of -- all postings before the report period. Unless altered by, -- a query, this is what you would see on a bank statement. - deriving (Eq,Show,Data,Typeable) + deriving (Eq,Show) instance Default BalanceType where def = PeriodChange -- | Should accounts be displayed: in the command's default style, hierarchically, or as a flat list ? -data AccountListMode = ALFlat | ALTree deriving (Eq, Show, Data, Typeable) +data AccountListMode = ALFlat | ALTree deriving (Eq, Show) instance Default AccountListMode where def = ALFlat @@ -140,7 +137,7 @@ data ReportOpts = ReportOpts { -- TERM and existence of NO_COLOR environment variables. ,forecast_ :: Maybe DateSpan ,transpose_ :: Bool - } deriving (Show, Data, Typeable) + } deriving (Show) instance Default ReportOpts where def = defreportopts diff --git a/hledger-lib/Hledger/Reports/TransactionsReport.hs b/hledger-lib/Hledger/Reports/TransactionsReport.hs index a2994bd0e..7caea34c7 100644 --- a/hledger-lib/Hledger/Reports/TransactionsReport.hs +++ b/hledger-lib/Hledger/Reports/TransactionsReport.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, RecordWildCards, DeriveDataTypeable, FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings, RecordWildCards, FlexibleInstances #-} {-| A transactions report. Like an EntriesReport, but with more diff --git a/hledger-lib/Hledger/Utils/Regex.hs b/hledger-lib/Hledger/Utils/Regex.hs index ba12cb896..5482b7107 100644 --- a/hledger-lib/Hledger/Utils/Regex.hs +++ b/hledger-lib/Hledger/Utils/Regex.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -80,7 +79,6 @@ import Control.Monad (foldM) 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.MemoUgly (memo) import qualified Data.Text as T @@ -124,11 +122,6 @@ instance Read Regexp where (m,t) <- readsPrec (app_prec+1) s]) r where app_prec = 10 -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 diff --git a/hledger-ui/Hledger/UI/UIOptions.hs b/hledger-ui/Hledger/UI/UIOptions.hs index 3e42dced8..755edda63 100644 --- a/hledger-ui/Hledger/UI/UIOptions.hs +++ b/hledger-ui/Hledger/UI/UIOptions.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE LambdaCase #-} {-| diff --git a/hledger/Hledger/Cli/CliOptions.hs b/hledger/Hledger/Cli/CliOptions.hs index 8e4ebfc22..bc0adca41 100644 --- a/hledger/Hledger/Cli/CliOptions.hs +++ b/hledger/Hledger/Cli/CliOptions.hs @@ -5,7 +5,7 @@ related utilities used by hledger commands. -} -{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable, FlexibleContexts, TypeFamilies, OverloadedStrings, PackageImports #-} +{-# LANGUAGE CPP, ScopedTypeVariables, FlexibleContexts, TypeFamilies, OverloadedStrings, PackageImports #-} module Hledger.Cli.CliOptions ( @@ -413,7 +413,7 @@ data CliOpts = CliOpts { -- 1. the COLUMNS env var, if set -- 2. the width reported by the terminal, if supported -- 3. the default (80) - } deriving (Show, Data, Typeable) + } deriving (Show) instance Default CliOpts where def = defcliopts diff --git a/hledger/Hledger/Cli/Commands/Add.hs b/hledger/Hledger/Cli/Commands/Add.hs index bfbf9313a..36cf89b79 100644 --- a/hledger/Hledger/Cli/Commands/Add.hs +++ b/hledger/Hledger/Cli/Commands/Add.hs @@ -3,7 +3,7 @@ A history-aware add command to help with data entry. |-} {-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-unused-do-bind #-} -{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, RecordWildCards, TypeOperators, FlexibleContexts, OverloadedStrings, PackageImports, LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables, RecordWildCards, TypeOperators, FlexibleContexts, OverloadedStrings, PackageImports, LambdaCase #-} {-# LANGUAGE TemplateHaskell #-} module Hledger.Cli.Commands.Add ( @@ -32,7 +32,6 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time.Calendar (Day) import Data.Time.Format (formatTime, defaultTimeLocale, iso8601DateFormat) -import Data.Typeable (Typeable) import Safe (headDef, headMay, atMay) import System.Console.CmdArgs.Explicit import System.Console.Haskeline (runInputT, defaultSettings, setComplete) @@ -65,7 +64,7 @@ data EntryState = EntryState { ,esJournal :: Journal -- ^ the journal we are adding to ,esSimilarTransaction :: Maybe Transaction -- ^ the most similar historical txn ,esPostings :: [Posting] -- ^ postings entered so far in the current txn - } deriving (Show,Typeable) + } deriving (Show) defEntryState = EntryState { esOpts = defcliopts @@ -77,10 +76,10 @@ defEntryState = EntryState { ,esPostings = [] } -data RestartTransactionException = RestartTransactionException deriving (Typeable,Show) +data RestartTransactionException = RestartTransactionException deriving (Show) instance Exception RestartTransactionException --- data ShowHelpException = ShowHelpException deriving (Typeable,Show) +-- data ShowHelpException = ShowHelpException deriving (Show) -- instance Exception ShowHelpException -- | Read multiple transactions from the console, prompting for each From 2cd7877c46a625dcdfcc6a06b20a9684f4810b3b Mon Sep 17 00:00:00 2001 From: Stephen Morgan Date: Mon, 31 Aug 2020 15:25:05 +1000 Subject: [PATCH 06/11] lib: Remove unnecessary NFData instances. --- hledger-lib/Hledger/Data/Types.hs | 53 --------------------------- hledger-lib/Hledger/Data/Valuation.hs | 3 -- hledger-lib/hledger-lib.cabal | 7 +--- hledger-lib/package.yaml | 1 - 4 files changed, 2 insertions(+), 62 deletions(-) diff --git a/hledger-lib/Hledger/Data/Types.hs b/hledger-lib/Hledger/Data/Types.hs index 7b7f266b4..4d1f63b15 100644 --- a/hledger-lib/Hledger/Data/Types.hs +++ b/hledger-lib/Hledger/Data/Types.hs @@ -28,7 +28,6 @@ module Hledger.Data.Types where import GHC.Generics (Generic) -import Control.DeepSeq (NFData) import Data.Decimal import Data.Default import Data.Functor (($>)) @@ -79,8 +78,6 @@ data DateSpan = DateSpan (Maybe Day) (Maybe Day) deriving (Eq,Ord,Generic) instance Default DateSpan where def = DateSpan Nothing Nothing -instance NFData DateSpan - -- synonyms for various date-related scalars type Year = Integer type Month = Int -- 1-12 @@ -135,8 +132,6 @@ data Interval = instance Default Interval where def = NoInterval -instance NFData Interval - type AccountName = Text data AccountType = @@ -148,8 +143,6 @@ data AccountType = | Cash -- ^ a subtype of Asset - liquid assets to show in cashflow report deriving (Show,Eq,Ord,Generic) -instance NFData AccountType - -- not worth the trouble, letters defined in accountdirectivep for now --instance Read AccountType -- where @@ -164,12 +157,8 @@ data AccountAlias = BasicAlias AccountName AccountName | RegexAlias Regexp Replacement deriving (Eq, Read, Show, Ord, Generic) --- instance NFData AccountAlias - data Side = L | R deriving (Eq,Show,Read,Ord,Generic) -instance NFData Side - -- | The basic numeric type used in amounts. type Quantity = Decimal -- The following is for hledger-web, and requires blaze-markup. @@ -184,8 +173,6 @@ instance ToMarkup Quantity data AmountPrice = UnitPrice Amount | TotalPrice Amount deriving (Eq,Ord,Generic,Show) -instance NFData AmountPrice - -- | Display style for an amount. data AmountStyle = AmountStyle { ascommodityside :: Side, -- ^ does the symbol appear on the left or the right ? @@ -195,8 +182,6 @@ data AmountStyle = AmountStyle { asdigitgroups :: Maybe DigitGroupStyle -- ^ style for displaying digit groups, if any } deriving (Eq,Ord,Read,Generic) -instance NFData AmountStyle - instance Show AmountStyle where show AmountStyle{..} = printf "AmountStylePP \"%s %s %s %s %s..\"" @@ -208,8 +193,6 @@ instance Show AmountStyle where data AmountPrecision = Precision !Word8 | NaturalPrecision deriving (Eq,Ord,Read,Show,Generic) -instance NFData AmountPrecision - -- | A style for displaying digit groups in the integer part of a -- floating point number. It consists of the character used to -- separate groups (comma or period, whichever is not used as decimal @@ -219,8 +202,6 @@ instance NFData AmountPrecision data DigitGroupStyle = DigitGroups Char [Word8] deriving (Eq,Ord,Read,Show,Generic) -instance NFData DigitGroupStyle - type CommoditySymbol = Text data Commodity = Commodity { @@ -228,8 +209,6 @@ data Commodity = Commodity { cformat :: Maybe AmountStyle } deriving (Show,Eq,Generic) --,Ord) -instance NFData Commodity - data Amount = Amount { acommodity :: CommoditySymbol, -- commodity symbol, or special value "AUTO" aquantity :: Quantity, -- numeric quantity, or zero in case of "AUTO" @@ -239,17 +218,11 @@ data Amount = Amount { aprice :: Maybe AmountPrice -- ^ the (fixed, transaction-specific) price for this amount, if any } deriving (Eq,Ord,Generic,Show) -instance NFData Amount - newtype MixedAmount = Mixed [Amount] deriving (Eq,Ord,Generic,Show) -instance NFData MixedAmount - data PostingType = RegularPosting | VirtualPosting | BalancedVirtualPosting deriving (Eq,Show,Generic) -instance NFData PostingType - type TagName = Text type TagValue = Text type Tag = (TagName, TagValue) -- ^ A tag name and (possibly empty) value. @@ -260,8 +233,6 @@ type DateTag = (TagName, Day) data Status = Unmarked | Pending | Cleared deriving (Eq,Ord,Bounded,Enum,Generic) -instance NFData Status - instance Show Status where -- custom show.. bad idea.. don't do it.. show Unmarked = "" show Pending = "!" @@ -311,8 +282,6 @@ data BalanceAssertion = BalanceAssertion { baposition :: GenericSourcePos -- ^ the assertion's file position, for error reporting } deriving (Eq,Generic,Show) -instance NFData BalanceAssertion - data Posting = Posting { pdate :: Maybe Day, -- ^ this posting's date, if different from the transaction's pdate2 :: Maybe Day, -- ^ this posting's secondary date, if different from the transaction's @@ -332,8 +301,6 @@ data Posting = Posting { -- untransformed posting (which will have Nothing in this field). } deriving (Generic) -instance NFData Posting - -- The equality test for postings ignores the parent transaction's -- identity, to avoid recurring ad infinitum. -- XXX could check that it's Just or Nothing. @@ -362,8 +329,6 @@ data GenericSourcePos = GenericSourcePos FilePath Int Int -- ^ file path, 1-b | JournalSourcePos FilePath (Int, Int) -- ^ file path, inclusive range of 1-based line numbers (first, last). deriving (Eq, Read, Show, Ord, Generic) -instance NFData GenericSourcePos - --{-# ANN Transaction "HLint: ignore" #-} -- Ambiguous type variable ‘p0’ arising from an annotation -- prevents the constraint ‘(Data p0)’ from being solved. @@ -382,8 +347,6 @@ data Transaction = Transaction { tpostings :: [Posting] -- ^ this transaction's postings } deriving (Eq,Generic,Show) -instance NFData Transaction - -- | A transaction modifier rule. This has a query which matches postings -- in the journal, and a list of transformations to apply to those -- postings or their transactions. Currently there is one kind of transformation: @@ -394,8 +357,6 @@ data TransactionModifier = TransactionModifier { tmpostingrules :: [TMPostingRule] } deriving (Eq,Generic,Show) -instance NFData TransactionModifier - nulltransactionmodifier = TransactionModifier{ tmquerytxt = "" ,tmpostingrules = [] @@ -433,12 +394,8 @@ nullperiodictransaction = PeriodicTransaction{ ,ptpostings = [] } -instance NFData PeriodicTransaction - data TimeclockCode = SetBalance | SetRequiredHours | In | Out | FinalOut deriving (Eq,Ord,Generic) -instance NFData TimeclockCode - data TimeclockEntry = TimeclockEntry { tlsourcepos :: GenericSourcePos, tlcode :: TimeclockCode, @@ -447,8 +404,6 @@ data TimeclockEntry = TimeclockEntry { tldescription :: Text } deriving (Eq,Ord,Generic) -instance NFData TimeclockEntry - -- | A market price declaration made by the journal format's P directive. -- It declares two things: a historical exchange rate between two commodities, -- and an amount display style for the second commodity. @@ -459,8 +414,6 @@ data PriceDirective = PriceDirective { } deriving (Eq,Ord,Generic,Show) -- Show instance derived in Amount.hs (XXX why ?) -instance NFData PriceDirective - -- | A historical market price (exchange rate) from one commodity to another. -- A more concise form of a PriceDirective, without the amount display info. data MarketPrice = MarketPrice { @@ -471,8 +424,6 @@ data MarketPrice = MarketPrice { } deriving (Eq,Ord,Generic) -- Show instance derived in Amount.hs (XXX why ?) -instance NFData MarketPrice - -- additional valuation-related types in Valuation.hs -- | A Journal, containing transactions and various other things. @@ -512,8 +463,6 @@ data Journal = Journal { } deriving (Eq, Generic) deriving instance Generic ClockTime -instance NFData ClockTime --- 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. @@ -532,8 +481,6 @@ data AccountDeclarationInfo = AccountDeclarationInfo { -- relative to other account declarations, during parsing (1..) } deriving (Eq,Show,Generic) -instance NFData AccountDeclarationInfo - nullaccountdeclarationinfo = AccountDeclarationInfo { adicomment = "" ,aditags = [] diff --git a/hledger-lib/Hledger/Data/Valuation.hs b/hledger-lib/Hledger/Data/Valuation.hs index 506beeb89..2c2ec534e 100644 --- a/hledger-lib/Hledger/Data/Valuation.hs +++ b/hledger-lib/Hledger/Data/Valuation.hs @@ -28,7 +28,6 @@ module Hledger.Data.Valuation ( where import Control.Applicative ((<|>)) -import Control.DeepSeq (NFData) import Data.Decimal (roundTo) import Data.Function ((&), on) import Data.Graph.Inductive (Gr, Node, NodeMap, mkMapGraph, mkNode, lab, out, sp) @@ -86,8 +85,6 @@ data PriceGraph = PriceGraph { } deriving (Show,Generic) -instance NFData PriceGraph - -- | A price oracle is a magic memoising function that efficiently -- looks up market prices (exchange rates) from one commodity to -- another (or if unspecified, to a default valuation commodity) on a diff --git a/hledger-lib/hledger-lib.cabal b/hledger-lib/hledger-lib.cabal index 0424305c9..281467513 100644 --- a/hledger-lib/hledger-lib.cabal +++ b/hledger-lib/hledger-lib.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.2. -- -- see: https://github.com/sol/hpack -- --- hash: ca2b9f025d75c0b65f91b2e5fe7203d00d1d9f8c423c8c4f0cb7675df848a5aa +-- hash: e8ee8c99329f53fe86ae9df138d05c8c39726a66da2ad1da3ae27500c45b2591 name: hledger-lib version: 1.18.99 @@ -124,7 +124,6 @@ library , cmdargs >=0.10 , containers , data-default >=0.5 - , deepseq , directory , extra >=1.6.3 , fgl >=5.5.4.0 @@ -177,7 +176,6 @@ test-suite doctest , cmdargs >=0.10 , containers , data-default >=0.5 - , deepseq , directory , doctest >=0.16.3 , extra >=1.6.3 @@ -233,7 +231,6 @@ test-suite unittest , cmdargs >=0.10 , containers , data-default >=0.5 - , deepseq , directory , extra >=1.6.3 , fgl >=5.5.4.0 diff --git a/hledger-lib/package.yaml b/hledger-lib/package.yaml index 1353382b8..35c6092e1 100644 --- a/hledger-lib/package.yaml +++ b/hledger-lib/package.yaml @@ -59,7 +59,6 @@ dependencies: - cassava-megaparsec - data-default >=0.5 - Decimal >=0.5.1 -- deepseq - directory - fgl >=5.5.4.0 - file-embed >=0.0.10 From 8dfffb1e611a5a268b7fcabd8f497e05ee15a04d Mon Sep 17 00:00:00 2001 From: Stephen Morgan Date: Mon, 31 Aug 2020 16:25:28 +1000 Subject: [PATCH 07/11] lib,web: Replace regex functions with simple text replacement. --- hledger-lib/Hledger/Data/AccountName.hs | 14 ++++++++------ hledger-web/Hledger/Web/Widget/AddForm.hs | 7 ++----- hledger-web/Hledger/Web/Widget/Common.hs | 2 +- 3 files changed, 11 insertions(+), 12 deletions(-) diff --git a/hledger-lib/Hledger/Data/AccountName.hs b/hledger-lib/Hledger/Data/AccountName.hs index d773905d8..ce137e868 100644 --- a/hledger-lib/Hledger/Data/AccountName.hs +++ b/hledger-lib/Hledger/Data/AccountName.hs @@ -39,14 +39,14 @@ module Hledger.Data.AccountName ( ) where -import Data.List import Data.List.Extra (nubSort) +import qualified Data.List.NonEmpty as NE #if !(MIN_VERSION_base(4,11,0)) -import Data.Monoid +import Data.Semigroup ((<>)) #endif import Data.Text (Text) import qualified Data.Text as T -import Data.Tree +import Data.Tree (Tree(..)) import Hledger.Data.Types import Hledger.Utils @@ -115,7 +115,7 @@ expandAccountNames as = nubSort $ concatMap expandAccountName as -- | "a:b:c" -> ["a","a:b","a:b:c"] expandAccountName :: AccountName -> [AccountName] -expandAccountName = map accountNameFromComponents . tail . inits . accountNameComponents +expandAccountName = map accountNameFromComponents . NE.tail . NE.inits . accountNameComponents -- | ["a:b:c","d:e"] -> ["a","d"] topAccountNames :: [AccountName] -> [AccountName] @@ -209,8 +209,10 @@ clipOrEllipsifyAccountName n = clipAccountName n -- >>> putStr $ escapeName "First?!#$*?$(*) !@^#*? %)*!@#" -- First\?!#\$\*\?\$\(\*\) !@\^#\*\? %\)\*!@# escapeName :: AccountName -> String -escapeName = replaceAllBy (toRegex' "[[?+|()*\\\\^$]") ("\\" <>) -- PARTIAL: should not happen - . T.unpack +escapeName = T.unpack . T.concatMap escapeChar + where + escapeChar c = if c `elem` escapedChars then T.snoc "\\" c else T.singleton c + escapedChars = ['[', '?', '+', '|', '(', ')', '*', '$', '^', '\\'] -- | Convert an account name to a regular expression matching it and its subaccounts. accountNameToAccountRegex :: AccountName -> Regexp diff --git a/hledger-web/Hledger/Web/Widget/AddForm.hs b/hledger-web/Hledger/Web/Widget/AddForm.hs index e47644118..bc9138c08 100644 --- a/hledger-web/Hledger/Web/Widget/AddForm.hs +++ b/hledger-web/Hledger/Web/Widget/AddForm.hs @@ -106,16 +106,13 @@ addForm j today = identifyForm "add" $ \extra -> do intercalate "," $ map ( ("{\"value\":" ++). (++"}"). - escapeJSSpecialChars . - drop 7 . -- "String " show . - toJSON + -- avoid https://github.com/simonmichael/hledger/issues/236 + T.replace "" "<\\/script>" ) ts, "]" ] where - -- avoid https://github.com/simonmichael/hledger/issues/236 - 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 908c6e26e..4b75d3c36 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 (toRegex' "\r") "" $ T.unpack t + let t' = T.replace "\r" "" t liftIO (readJournal def (Just f) t') >>= \case Left e -> return (Left e) Right _ -> do From 20b39a5dd0e3d3d1889e0dd6a3d40858f5847d13 Mon Sep 17 00:00:00 2001 From: Stephen Morgan Date: Mon, 31 Aug 2020 20:03:34 +1000 Subject: [PATCH 08/11] lib: Remove unused --display code. This was dropped back in 2014, and getting rid of this removes a use of regular expressions. --- hledger-lib/Hledger/Reports/PostingsReport.hs | 2 +- hledger-lib/Hledger/Reports/ReportOptions.hs | 12 ------------ 2 files changed, 1 insertion(+), 13 deletions(-) diff --git a/hledger-lib/Hledger/Reports/PostingsReport.hs b/hledger-lib/Hledger/Reports/PostingsReport.hs index dadb7b699..b70c6eb4f 100644 --- a/hledger-lib/Hledger/Reports/PostingsReport.hs +++ b/hledger-lib/Hledger/Reports/PostingsReport.hs @@ -373,7 +373,7 @@ tests_PostingsReport = tests "PostingsReport" [ j <- samplejournal let gives displayexpr = (registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is`) - where opts = defreportopts{display_=Just displayexpr} + where opts = defreportopts "d<[2008/6/2]" `gives` ["2008/01/01","2008/06/01"] "d<=[2008/6/2]" `gives` ["2008/01/01","2008/06/01","2008/06/02"] "d=[2008/6/2]" `gives` ["2008/06/02"] diff --git a/hledger-lib/Hledger/Reports/ReportOptions.hs b/hledger-lib/Hledger/Reports/ReportOptions.hs index 2ce27dd20..a1731647b 100644 --- a/hledger-lib/Hledger/Reports/ReportOptions.hs +++ b/hledger-lib/Hledger/Reports/ReportOptions.hs @@ -98,7 +98,6 @@ data ReportOpts = ReportOpts { ,value_ :: Maybe ValuationType -- ^ What value should amounts be converted to ? ,infer_value_ :: Bool -- ^ Infer market prices from transactions ? ,depth_ :: Maybe Int - ,display_ :: Maybe DisplayExp -- XXX unused ? ,date2_ :: Bool ,empty_ :: Bool ,no_elide_ :: Bool @@ -172,7 +171,6 @@ defreportopts = ReportOpts def def def - def rawOptsToReportOpts :: RawOpts -> IO ReportOpts rawOptsToReportOpts rawopts = checkReportOpts <$> do @@ -189,7 +187,6 @@ rawOptsToReportOpts rawopts = checkReportOpts <$> do ,value_ = valuationTypeFromRawOpts rawopts' ,infer_value_ = boolopt "infer-value" rawopts' ,depth_ = maybeposintopt "depth" rawopts' - ,display_ = maybedisplayopt d rawopts' ,date2_ = boolopt "date2" rawopts' ,empty_ = boolopt "empty" rawopts' ,no_elide_ = boolopt "no-elide" rawopts' @@ -416,15 +413,6 @@ valuationTypeIsDefaultValue ropts = Just (AtDefault _) -> True _ -> False -type DisplayExp = String - -maybedisplayopt :: Day -> RawOpts -> Maybe DisplayExp -maybedisplayopt d rawopts = - 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) transactionDateFn ReportOpts{..} = if date2_ then transactionDate2 else tdate From b91b391d083db84f8f4eee6cf50774279ae7189e Mon Sep 17 00:00:00 2001 From: Stephen Morgan Date: Mon, 31 Aug 2020 22:44:41 +1000 Subject: [PATCH 09/11] lib: Replace some regex functions with parsers. --- hledger-lib/Hledger/Read/CsvReader.hs | 32 ++++++++++++++++----------- hledger-lib/Hledger/Utils/String.hs | 21 ++++++++++-------- 2 files changed, 31 insertions(+), 22 deletions(-) diff --git a/hledger-lib/Hledger/Read/CsvReader.hs b/hledger-lib/Hledger/Read/CsvReader.hs index 450c00f25..eb5f36c1c 100644 --- a/hledger-lib/Hledger/Read/CsvReader.hs +++ b/hledger-lib/Hledger/Read/CsvReader.hs @@ -41,6 +41,7 @@ where --- ** imports import Prelude () import "base-compat-batteries" Prelude.Compat hiding (fail) +import Control.Applicative (liftA2) import Control.Exception (IOException, handle, throw) import Control.Monad (liftM, unless, when) import Control.Monad.Except (ExceptT, throwError) @@ -48,13 +49,13 @@ 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) -import Data.Char (toLower, isDigit, isSpace, isAlphaNum, ord) +import Data.Char (toLower, isDigit, isSpace, isAlphaNum, isAscii, ord) import Data.Bifunctor (first) import "base-compat-batteries" Data.List.Compat import qualified Data.List.Split as LS (splitOn) -import Data.Maybe +import Data.Maybe (catMaybes, fromMaybe, isJust) import Data.MemoUgly (memo) -import Data.Ord +import Data.Ord (comparing) import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T @@ -62,17 +63,17 @@ import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import Data.Time.Calendar (Day) import Data.Time.Format (parseTimeM, defaultTimeLocale) -import Safe +import Safe (atMay, headMay, lastMay, readDef, readMay) import System.Directory (doesFileExist) -import System.FilePath +import System.FilePath ((), takeDirectory, takeExtension, takeFileName) import qualified Data.Csv as Cassava 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 Data.Foldable (asum, toList) import Text.Megaparsec hiding (match, parse) -import Text.Megaparsec.Char -import Text.Megaparsec.Custom +import Text.Megaparsec.Char (char, newline, string) +import Text.Megaparsec.Custom (customErrorBundlePretty, parseErrorAt) import Text.Printf (printf) import Hledger.Data @@ -834,10 +835,9 @@ validateCsv rules numhdrlines (Right rs) = validate $ applyConditionalSkips $ dr Nothing -> r:(applyConditionalSkips rest) Just cnt -> applyConditionalSkips (drop (cnt-1) rest) validate [] = Right [] - validate rs@(_first:_) - | isJust lessthan2 = let r = fromJust lessthan2 in - Left $ printf "CSV record %s has less than two fields" (show r) - | otherwise = Right rs + validate rs@(_first:_) = case lessthan2 of + Just r -> Left $ printf "CSV record %s has less than two fields" (show r) + Nothing -> Right rs where lessthan2 = headMay $ filter ((<2).length) rs @@ -1199,7 +1199,13 @@ 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 = replaceAllBy (toRegex' "%[A-z0-9_-]+") (replaceCsvFieldReference rules record) t -- PARTIAL: should not happen +renderTemplate rules record t = maybe t concat $ parseMaybe + (many $ takeWhile1P Nothing (/='%') + <|> replaceCsvFieldReference rules record <$> referencep) + t + where + referencep = liftA2 (:) (char '%') (takeWhile1P (Just "reference") isDescriptorChar) :: Parsec CustomErr String String + isDescriptorChar c = isAscii c && (isAlphaNum c || c == '_' || c == '-') -- | 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 diff --git a/hledger-lib/Hledger/Utils/String.hs b/hledger-lib/Hledger/Utils/String.hs index 41923e495..870063a63 100644 --- a/hledger-lib/Hledger/Utils/String.hs +++ b/hledger-lib/Hledger/Utils/String.hs @@ -49,14 +49,14 @@ module Hledger.Utils.String ( ) where -import Data.Char -import Data.List -import Text.Megaparsec -import Text.Megaparsec.Char +import Data.Char (isDigit, isSpace, toLower, toUpper) +import Data.List (intercalate, transpose) +import Text.Megaparsec (Parsec, (<|>), (), between, many, noneOf, oneOf, + parseMaybe, sepBy, takeWhile1P) +import Text.Megaparsec.Char (char, string) import Text.Printf (printf) import Hledger.Utils.Parse -import Hledger.Utils.Regex -- | Take elements from the end of a list. @@ -341,12 +341,15 @@ takeWidth w (c:cs) | cw <= w = c:takeWidth (w-cw) cs -- (not counted), and line breaks (in a multi-line string, the longest -- line determines the width). strWidth :: String -> Int -strWidth "" = 0 -strWidth s = maximum $ map (foldr (\a b -> charWidth a + b) 0) $ lines s' - where s' = stripAnsi s +strWidth = maximum . (0:) . map (foldr (\a b -> charWidth a + b) 0) . lines . stripAnsi stripAnsi :: String -> String -stripAnsi = regexReplace (toRegex' "\ESC\\[([0-9]+;)*([0-9]+)?[ABCDHJKfmsu]") "" -- PARTIAL: should never happen, no backreferences +stripAnsi s = maybe s concat $ parseMaybe (many $ takeWhile1P Nothing (/='\ESC') <|> "" <$ ansi) s + where + -- This parses lots of invalid ANSI escape codes, but that should be fine + ansi = string "\ESC[" *> digitSemicolons *> suffix "ansi" :: Parsec CustomErr String Char + digitSemicolons = takeWhile1P Nothing (\c -> isDigit c || c == ';') + suffix = oneOf ['A', 'B', 'C', 'D', 'H', 'J', 'K', 'f', 'm', 's', 'u'] -- | Get the designated render width of a character: 0 for a combining -- character, 1 for a regular character, 2 for a wide character. From 07dd30c1e55bd31748ad54e48e3aff3fe28a0f72 Mon Sep 17 00:00:00 2001 From: Stephen Morgan Date: Tue, 1 Sep 2020 11:36:34 +1000 Subject: [PATCH 10/11] lib,cli,ui: Change to consistent naming scheme for Hledger.Utils.Regex. --- hledger-lib/Hledger/Data/Posting.hs | 2 +- hledger-lib/Hledger/Query.hs | 49 +++++---- hledger-lib/Hledger/Read/Common.hs | 2 +- hledger-lib/Hledger/Read/CsvReader.hs | 6 +- hledger-lib/Hledger/Read/JournalReader.hs | 2 +- hledger-lib/Hledger/Utils/Regex.hs | 125 ++++++++++------------ hledger-ui/Hledger/UI/AccountsScreen.hs | 2 +- hledger-ui/Hledger/UI/Main.hs | 8 +- hledger-ui/Hledger/UI/RegisterScreen.hs | 2 +- hledger/Hledger/Cli/Commands/Aregister.hs | 10 +- hledger/Hledger/Cli/Commands/Files.hs | 4 +- hledger/Hledger/Cli/Commands/Tags.hs | 4 +- 12 files changed, 109 insertions(+), 107 deletions(-) diff --git a/hledger-lib/Hledger/Data/Posting.hs b/hledger-lib/Hledger/Data/Posting.hs index 64f8a6ec4..db03c9745 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 $ regexReplaceMemo_ re repl $ T.unpack a -- XXX + fmap T.pack . regexReplace 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/Query.hs b/hledger-lib/Hledger/Query.hs index c4ef59b7e..98c91b24b 100644 --- a/hledger-lib/Hledger/Query.hs +++ b/hledger-lib/Hledger/Query.hs @@ -18,6 +18,9 @@ module Hledger.Query ( -- * Query and QueryOpt Query(..), QueryOpt(..), + payeeTag, + noteTag, + generatedTransactionTag, -- * parsing parseQuery, simplifyQuery, @@ -58,7 +61,7 @@ module Hledger.Query ( ) where -import Control.Applicative ((<|>), liftA2, many, optional) +import Control.Applicative ((<|>), many, optional) import Data.Either (partitionEithers) import Data.List (partition) import Data.Maybe (fromMaybe, isJust, mapMaybe) @@ -107,11 +110,15 @@ data Query = Any -- ^ always match -- | Construct a payee tag payeeTag :: Maybe String -> Either RegexError Query -payeeTag = liftA2 Tag (toRegexCI_ "payee") . maybe (pure Nothing) (fmap Just . toRegexCI_) +payeeTag = fmap (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_) +noteTag = fmap (Tag (toRegexCI' "note")) . maybe (pure Nothing) (fmap Just . toRegexCI) + +-- | Construct a generated-transaction tag +generatedTransactionTag :: Query +generatedTransactionTag = Tag (toRegexCI' "generated-transaction") Nothing -- | A more expressive Ord, used for amt: queries. The Abs* variants -- compare with the absolute value of a number, ignoring sign. @@ -254,11 +261,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) = Left . Code <$> toRegexCI_ (T.unpack s) -parseQueryTerm _ (T.stripPrefix "desc:" -> Just s) = Left . Desc <$> toRegexCI_ (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 _ (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 @@ -276,7 +283,7 @@ 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) = Left . Sym <$> toRegexCI_ ('^' : T.unpack s ++ "$") -- support cur: as an alias +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 @@ -327,8 +334,8 @@ parseAmountQueryTerm amtarg = 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) + 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 @@ -551,7 +558,7 @@ 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 = match r (T.unpack a) -- XXX pack +matchesAccount (Acct r) a = regexMatch r $ T.unpack a -- XXX pack matchesAccount (Depth d) a = accountNameLevel a <= d matchesAccount (Tag _ _) _ = False matchesAccount _ _ = True @@ -561,7 +568,7 @@ matchesMixedAmount q (Mixed []) = q `matchesAmount` nullamt matchesMixedAmount q (Mixed as) = any (q `matchesAmount`) as matchesCommodity :: Query -> CommoditySymbol -> Bool -matchesCommodity (Sym r) = match r . T.unpack +matchesCommodity (Sym r) = regexMatch r . T.unpack matchesCommodity _ = const True -- | Does the match expression match this (simple) amount ? @@ -600,10 +607,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 = match r $ maybe "" (T.unpack . tcode) $ ptransaction p -matchesPosting (Desc r) p = match r $ maybe "" (T.unpack . tdescription) $ ptransaction p +matchesPosting (Code r) p = regexMatch r $ maybe "" (T.unpack . tcode) $ ptransaction p +matchesPosting (Desc r) p = regexMatch r $ maybe "" (T.unpack . tdescription) $ ptransaction p matchesPosting (Acct r) p = matches p || matches (originalPosting p) - where matches p = match r . T.unpack $ paccount p -- XXX pack + where matches p = regexMatch 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 @@ -617,8 +624,8 @@ matchesPosting q@(Amt _ _) Posting{pamount=amt} = q `matchesMixedAmount` amt matchesPosting (Empty _) _ = True matchesPosting (Sym r) Posting{pamount=Mixed as} = any (matchesCommodity (Sym r)) $ map acommodity as 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 + ("payee", Just v) -> maybe False (regexMatch v . T.unpack . transactionPayee) $ ptransaction p + ("note", Just v) -> maybe False (regexMatch v . T.unpack . transactionNote) $ ptransaction p (_, v) -> matchesTags n v $ postingAllTags p -- | Does the match expression match this transaction ? @@ -628,8 +635,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 = match r $ T.unpack $ tcode t -matchesTransaction (Desc r) t = match r $ T.unpack $ tdescription t +matchesTransaction (Code r) t = regexMatch r $ T.unpack $ tcode t +matchesTransaction (Desc r) t = regexMatch 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 @@ -640,15 +647,15 @@ 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 (reString n, v) of - ("payee", Just v) -> match v . T.unpack . transactionPayee $ t - ("note", Just v) -> match v . T.unpack . transactionNote $ t + ("payee", Just v) -> regexMatch v . T.unpack . transactionPayee $ t + ("note", Just v) -> regexMatch v . T.unpack . transactionNote $ t (_, 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 (matches namepat valuepat) where - matches npat vpat (n,v) = match npat (T.unpack n) && maybe (const True) match vpat (T.unpack v) + matches npat vpat (n,v) = regexMatch npat (T.unpack n) && maybe (const True) regexMatch vpat (T.unpack v) -- | Does the query match this market price ? matchesPriceDirective :: Query -> PriceDirective -> Bool diff --git a/hledger-lib/Hledger/Read/Common.hs b/hledger-lib/Hledger/Read/Common.hs index 4ff896627..bd7751926 100644 --- a/hledger-lib/Hledger/Read/Common.hs +++ b/hledger-lib/Hledger/Read/Common.hs @@ -144,7 +144,7 @@ import Text.Megaparsec.Custom finalErrorBundlePretty, parseErrorAt, parseErrorAtRegion) import Hledger.Data -import Hledger.Utils hiding (match) +import Hledger.Utils --- ** doctest setup -- $setup diff --git a/hledger-lib/Hledger/Read/CsvReader.hs b/hledger-lib/Hledger/Read/CsvReader.hs index eb5f36c1c..612ffc058 100644 --- a/hledger-lib/Hledger/Read/CsvReader.hs +++ b/hledger-lib/Hledger/Read/CsvReader.hs @@ -661,7 +661,7 @@ regexp end = do -- notFollowedBy matchoperatorp c <- lift nonspace cs <- anySingle `manyTill` end - case toRegexCI_ . strip $ c:cs of + case toRegexCI . strip $ c:cs of Left x -> Fail.fail $ "CSV parser: " ++ x Right x -> return x @@ -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) = match pat' wholecsvline + matcherMatches (RecordMatcher _ pat) = regexMatch 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) = match pat csvfieldvalue + matcherMatches (FieldMatcher _ csvfieldref pat) = regexMatch pat csvfieldvalue where -- the value of the referenced CSV field to match against. csvfieldvalue = dbg7 "csvfieldvalue" $ replaceCsvFieldReference rules record csvfieldref diff --git a/hledger-lib/Hledger/Read/JournalReader.hs b/hledger-lib/Hledger/Read/JournalReader.hs index 3d2749d5c..509069f8f 100644 --- a/hledger-lib/Hledger/Read/JournalReader.hs +++ b/hledger-lib/Hledger/Read/JournalReader.hs @@ -529,7 +529,7 @@ regexaliasp = do char '=' skipNonNewlineSpaces repl <- anySingle `manyTill` eolof - case toRegexCI_ re of + case toRegexCI re of Right r -> return $! RegexAlias r repl Left e -> customFailure $! parseErrorAtRegion off1 off2 e diff --git a/hledger-lib/Hledger/Utils/Regex.hs b/hledger-lib/Hledger/Utils/Regex.hs index 5482b7107..f57934ad2 100644 --- a/hledger-lib/Hledger/Utils/Regex.hs +++ b/hledger-lib/Hledger/Utils/Regex.hs @@ -29,14 +29,12 @@ functions have memoised variants (*Memo), which also trade space for time. Currently two APIs are provided: -- The old partial one which will call error on any problem (eg with malformed - regexps). This comes from hledger's origin as a command-line tool. +- The old partial one (with ' suffixes') which will call error on any problem + (eg with malformed regexps). This comes from hledger's origin as a + command-line tool. -- The new total one (with _ suffixes) which will return an error message. This - is better for long-running apps like hledger-web. - -We are gradually replacing usage of the old API in hledger. Probably at some -point the suffixless names will be reclaimed for the new API. +- The new total one which will return an error message. This is better for + long-running apps like hledger-web. Current limitations: @@ -47,31 +45,18 @@ Current limitations: module Hledger.Utils.Regex ( -- * Regexp type and constructors Regexp(reString) - ,toRegex_ - ,toRegexCI_ + ,toRegex + ,toRegexCI ,toRegex' ,toRegexCI' -- * type aliases ,Replacement ,RegexError - -- * partial regex operations (may call error) --- ,regexMatches --- ,regexMatchesCI --- ,regexReplaceCI --- ,regexReplaceCIMemo --- ,regexReplaceByCI -- * total regex operations - ,match + ,regexMatch ,regexReplace - ,regexReplaceMemo_ --- ,replaceAllBy --- ,regexMatches_ --- ,regexMatchesCI_ --- ,regexReplace_ --- ,regexReplaceCI_ --- ,regexReplaceMemo_ --- ,regexReplaceCIMemo_ - ,replaceAllBy + ,regexReplaceUnmemo + ,regexReplaceAllBy ) where @@ -139,12 +124,12 @@ instance RegexContext Regexp String String where 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) +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) +-- 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 @@ -153,11 +138,11 @@ mkRegexErr s = maybe (Left errmsg) Right -- Convert a Regexp string to a compiled Regex, throw an error toRegex' :: String -> Regexp -toRegex' = either error' id . toRegex_ +toRegex' = either error' id . toRegex -- Like toRegex', but make a case-insensitive Regex. toRegexCI' :: String -> Regexp -toRegexCI' = either error' id . toRegexCI_ +toRegexCI' = either error' id . toRegexCI -- | A replacement pattern. May include numeric backreferences (\N). type Replacement = String @@ -167,44 +152,30 @@ type RegexError = String -- helpers -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 - where - ((_,(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 backrefRegex (lookupMatchGroup matchgroups) replpat - where - lookupMatchGroup :: MatchText String -> String -> String - lookupMatchGroup grps ('\\':s@(_:_)) | all isDigit s = - case read s of n | n `elem` indices grps -> fst (grps ! n) - -- 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 +-- | Test whether a Regexp matches a String. This is an alias for `matchTest` for consistent +-- naming. +regexMatch :: Regexp -> String -> Bool +regexMatch = matchTest -------------------------------------------------------------------------------- -- new total functions --- | A memoising version of regexReplace_. Caches the result for each +-- | 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 (replaceRegexUnmemo_ re repl) +regexReplace :: Regexp -> Replacement -> String -> Either RegexError String +regexReplace re repl = memo $ regexReplaceUnmemo re repl -- helpers: -- Replace this regular expression with this replacement pattern in this -- string, or return an error message. -replaceRegexUnmemo_ :: Regexp -> Replacement -> String -> Either RegexError String -replaceRegexUnmemo_ re repl s = foldM (replaceMatch_ repl) s (reverse $ match (reCompiled re) s :: [MatchText String]) +regexReplaceUnmemo :: Regexp -> Replacement -> String -> Either RegexError String +regexReplaceUnmemo 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. - replaceMatch_ :: Replacement -> String -> MatchText String -> Either RegexError String - replaceMatch_ replpat s matchgroups = + replaceMatch :: Replacement -> String -> MatchText String -> Either RegexError String + replaceMatch replpat s matchgroups = erepl >>= \repl -> Right $ pre ++ repl ++ post where ((_,(off,len)):_) = elems matchgroups -- groups should have 0-based indexes, and there should always be at least one, since this is a match @@ -213,25 +184,46 @@ replaceRegexUnmemo_ re repl s = foldM (replaceMatch_ repl) s (reverse $ match (r -- The replacement text: the replacement pattern with all -- numeric backreferences replaced by the appropriate groups -- from this match. Or an error message. - erepl = replaceAllByM backrefRegex (lookupMatchGroup_ matchgroups) replpat + erepl = regexReplaceAllByM backrefRegex (lookupMatchGroup matchgroups) replpat where -- Given some match groups and a numeric backreference, -- return the referenced group text, or an error message. - lookupMatchGroup_ :: MatchText String -> String -> Either RegexError String - lookupMatchGroup_ grps ('\\':s@(_:_)) | all isDigit s = + lookupMatchGroup :: MatchText String -> String -> Either RegexError String + lookupMatchGroup grps ('\\':s@(_:_)) | all isDigit 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" + lookupMatchGroup _ s = Left $ "lookupMatchGroup called on non-numeric-backreference \""++s++"\", shouldn't happen" backrefRegex = toRegex' "\\\\[0-9]+" -- PARTIAL: should not happen +-- 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 +-- where +-- ((_,(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 = regexReplaceAllBy backrefRegex (lookupMatchGroup matchgroups) replpat +-- where +-- lookupMatchGroup :: MatchText String -> String -> String +-- lookupMatchGroup grps ('\\':s@(_:_)) | all isDigit s = +-- case read s of n | n `elem` indices grps -> fst (grps ! n) +-- -- 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 + + -- helpers -- adapted from http://stackoverflow.com/questions/9071682/replacement-substition-with-haskell-regex-libraries: -- Replace all occurrences of a regexp in a string, transforming each match -- with the given pure function. -replaceAllBy :: Regexp -> (String -> String) -> String -> String -replaceAllBy re transform s = prependdone rest +regexReplaceAllBy :: Regexp -> (String -> String) -> String -> String +regexReplaceAllBy re transform s = prependdone rest where (_, rest, prependdone) = foldl' go (0, s, id) matches where @@ -246,9 +238,9 @@ 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 => Regexp -> (String -> m String) -> String -> m String -replaceAllByM re transform s = - foldM go (0, s, id) matches >>= \(_, rest, prependdone) -> pure $ prependdone rest +regexReplaceAllByM :: forall m. Monad m => Regexp -> (String -> m String) -> String -> m String +regexReplaceAllByM re transform s = + foldM go (0, s, id) matches >>= \(_, rest, prependdone) -> pure $ prependdone rest where matches = getAllMatches $ match (reCompiled re) s :: [(Int, Int)] -- offset and length go :: (Int,String,String->String) -> (Int,Int) -> m (Int,String,String->String) @@ -256,4 +248,3 @@ replaceAllByM re transform s = let (prematch, matchandrest) = splitAt (off - pos) todo (matched, rest) = splitAt len matchandrest in transform matched >>= \matched' -> pure (off + len, rest, prepend . (prematch++) . (matched' ++)) - diff --git a/hledger-ui/Hledger/UI/AccountsScreen.hs b/hledger-ui/Hledger/UI/AccountsScreen.hs index 2e144f422..414831611 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 (toRegexCI' "generated-transaction") Nothing) + ,Not generatedTransactionTag ] -- run the report diff --git a/hledger-ui/Hledger/UI/Main.hs b/hledger-ui/Hledger/UI/Main.hs index 612631d9d..7c6ba4bc4 100644 --- a/hledger-ui/Hledger/UI/Main.hs +++ b/hledger-ui/Hledger/UI/Main.hs @@ -120,9 +120,11 @@ runBrickUi uopts@UIOpts{cliopts_=copts@CliOpts{inputopts_=_iopts,reportopts_=rop -- to that as usual. Just apat -> (rsSetAccount acct False registerScreen, [ascr']) where - acct = headDef - (error' $ "--register "++apat++" did not match any account") -- PARTIAL: - $ filter (match (toRegexCI' apat) . T.unpack) $ journalAccountNames j + acct = headDef (error' $ "--register "++apat++" did not match any account") -- PARTIAL: + . filterAccts $ journalAccountNames j + filterAccts = case toRegexCI apat of + Right re -> filter (regexMatch re . T.unpack) + Left _ -> const [] -- 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 5893f32a2..8424fef35 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 (toRegexCI' "generated-transaction") Nothing) + ,Not generatedTransactionTag ] (_label,items) = accountTransactionsReport ropts' j q thisacctq diff --git a/hledger/Hledger/Cli/Commands/Aregister.hs b/hledger/Hledger/Cli/Commands/Aregister.hs index 5be44e257..73d50d005 100644 --- a/hledger/Hledger/Cli/Commands/Aregister.hs +++ b/hledger/Hledger/Cli/Commands/Aregister.hs @@ -79,9 +79,11 @@ 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 (match apatregex . T.unpack) $ journalAccountNames j + acct = headDef (error' $ show apat++" did not match any account") -- PARTIAL: + . filterAccts $ journalAccountNames j + filterAccts = case toRegexCI apat of + Right re -> filter (regexMatch re . T.unpack) + Left _ -> const [] -- gather report options inclusive = True -- tree_ ropts thisacctq = Acct $ (if inclusive then accountNameToAccountRegex else accountNameToAccountOnlyRegex) acct @@ -100,7 +102,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 (toRegex' "generated-transaction") Nothing) + ,Not generatedTransactionTag ] -- run the report -- TODO: need to also pass the queries so we can choose which date to render - move them into the report ? diff --git a/hledger/Hledger/Cli/Commands/Files.hs b/hledger/Hledger/Cli/Commands/Files.hs index 1d80f28f8..49e8757c6 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 <- mapM (either fail pure . toRegex_) $ headMay args - let files = maybe id (filter . match) regex + regex <- mapM (either fail pure . toRegex) $ headMay args + let files = maybe id (filter . regexMatch) 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 c6e395226..82410706f 100755 --- a/hledger/Hledger/Cli/Commands/Tags.hs +++ b/hledger/Hledger/Cli/Commands/Tags.hs @@ -30,7 +30,7 @@ tags CliOpts{rawopts_=rawopts,reportopts_=ropts} j = do d <- getCurrentDay let args = listofstringopt "args" rawopts - mtagpat <- mapM (either Fail.fail pure . toRegexCI_) $ headMay args + mtagpat <- mapM (either Fail.fail pure . toRegexCI) $ headMay args let queryargs = drop 1 args values = boolopt "values" rawopts @@ -42,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 (`match` T.unpack t) mtagpat + , maybe True (`regexMatch` T.unpack t) mtagpat , let r = if values then v else t , not (values && T.null v && not empty) ] From 7d1e6d7d12f3c3a042661c1d6963523b5d5f676b Mon Sep 17 00:00:00 2001 From: Stephen Morgan Date: Tue, 1 Sep 2020 11:41:55 +1000 Subject: [PATCH 11/11] lib: Fix quoteIfNeeded so it actually escapes quotes. --- hledger-lib/Hledger/Utils/String.hs | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) diff --git a/hledger-lib/Hledger/Utils/String.hs b/hledger-lib/Hledger/Utils/String.hs index 870063a63..21aee9049 100644 --- a/hledger-lib/Hledger/Utils/String.hs +++ b/hledger-lib/Hledger/Utils/String.hs @@ -13,7 +13,6 @@ module Hledger.Utils.String ( singleQuoteIfNeeded, -- quotechars, -- whitespacechars, - escapeQuotes, words', unwords', stripAnsi, @@ -120,8 +119,9 @@ underline s = s' ++ replicate (length s) '-' ++ "\n" -- | Double-quote this string if it contains whitespace, single quotes -- or double-quotes, escaping the quotes as needed. quoteIfNeeded :: String -> String -quoteIfNeeded s | any (`elem` s) (quotechars++whitespacechars++redirectchars) = "\"" ++ escapeDoubleQuotes s ++ "\"" +quoteIfNeeded s | any (`elem` s) (quotechars++whitespacechars++redirectchars) = show s | otherwise = s + -- | Single-quote this string if it contains whitespace or double-quotes. -- No good for strings containing single quotes. singleQuoteIfNeeded :: String -> String @@ -133,12 +133,6 @@ quotechars = "'\"" whitespacechars = " \t\n\r" redirectchars = "<>" -escapeDoubleQuotes :: String -> String -escapeDoubleQuotes = id -- regexReplace "\"" "\"" - -escapeQuotes :: String -> String -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. words' :: String -> [String]