slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

lib,cli,ui,web: Make Regexp a wrapper for Regex.

Browse Source
This commit is contained in:
Stephen Morgan 2020-08-15 19:14:27 +10:00
parent ccd6fdd7b9
commit e5371d5a6a
25 changed files with 389 additions and 440 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
hledger-lib/Hledger/Data/Account.hs
View File

@ -14,7 +14,7 @@ import Data.List.Extra (groupSort, groupOn)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Ord (Down(..)) import Data.Ord (Down(..))
import qualified Data.Map as M import qualified Data.Map as M
import Data.Text (pack,unpack) import qualified Data.Text as T
import Safe (headMay, lookupJustDef) import Safe (headMay, lookupJustDef)
import Text.Printf import Text.Printf
@ -28,11 +28,12 @@ import Hledger.Utils
-- deriving instance Show Account -- deriving instance Show Account
instance Show Account where instance Show Account where
show Account{..} = printf "Account %s (boring:%s, postings:%d, ebalance:%s, ibalance:%s)" 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) (if aboring then "y" else "n" :: String)
anumpostings anumpostings
(showMixedAmount aebalance) (showMixedAmount aebalance)
(showMixedAmount aibalance) (showMixedAmount aibalance)
where colonToUnderscore x = if x == ':' then '_' else x
instance Eq Account where instance Eq Account where
(==) a b = aname a == aname b -- quick equality test for speed (==) a b = aname a == aname b -- quick equality test for speed

16
hledger-lib/Hledger/Data/AccountName.hs
View File

@ -18,7 +18,6 @@ module Hledger.Data.AccountName (
,accountNameToAccountOnlyRegex ,accountNameToAccountOnlyRegex
,accountNameToAccountRegex ,accountNameToAccountRegex
,accountNameTreeFrom ,accountNameTreeFrom
,accountRegexToAccountName
,accountSummarisedName ,accountSummarisedName
,acctsep ,acctsep
,acctsepchar ,acctsepchar
@ -48,7 +47,6 @@ import Data.Monoid
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Tree import Data.Tree
import Text.Printf
import Hledger.Data.Types import Hledger.Data.Types
import Hledger.Utils import Hledger.Utils
@ -210,23 +208,17 @@ clipOrEllipsifyAccountName n = clipAccountName n
-- | Escape an AccountName for use within a regular expression. -- | Escape an AccountName for use within a regular expression.
-- >>> putStr $ escapeName "First?!#$*?$(*) !@^#*? %)*!@#" -- >>> putStr $ escapeName "First?!#$*?$(*) !@^#*? %)*!@#"
-- First\?!#\$\*\?\$\(\*\) !@\^#\*\? %\)\*!@# -- First\?!#\$\*\?\$\(\*\) !@\^#\*\? %\)\*!@#
escapeName :: AccountName -> Regexp escapeName :: AccountName -> String
escapeName = regexReplaceBy "[[?+|()*\\\\^$]" ("\\" <>) escapeName = replaceAllBy (toRegex' "[[?+|()*\\\\^$]") ("\\" <>) -- PARTIAL: should not happen
. T.unpack . T.unpack
-- | Convert an account name to a regular expression matching it and its subaccounts. -- | Convert an account name to a regular expression matching it and its subaccounts.
accountNameToAccountRegex :: AccountName -> Regexp accountNameToAccountRegex :: AccountName -> Regexp
accountNameToAccountRegex "" = "" accountNameToAccountRegex a = toRegex' $ '^' : escapeName a ++ "(:|$)" -- PARTIAL: Is this safe after escapeName?
accountNameToAccountRegex a = printf "^%s(:|$)" (escapeName a)
-- | Convert an account name to a regular expression matching it but not its subaccounts. -- | Convert an account name to a regular expression matching it but not its subaccounts.
accountNameToAccountOnlyRegex :: AccountName -> Regexp accountNameToAccountOnlyRegex :: AccountName -> Regexp
accountNameToAccountOnlyRegex "" = "" accountNameToAccountOnlyRegex a = toRegex' $ '^' : escapeName a ++ "$" -- PARTIAL: Is this safe after escapeName?
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
-- -- | Does this string look like an exact account-matching regular expression ? -- -- | Does this string look like an exact account-matching regular expression ?
--isAccountRegex :: String -> Bool --isAccountRegex :: String -> Bool

51
hledger-lib/Hledger/Data/Journal.hs
View File

@ -74,7 +74,6 @@ module Hledger.Data.Journal (
journalCashAccountQuery, journalCashAccountQuery,
-- * Misc -- * Misc
canonicalStyleFrom, canonicalStyleFrom,
matchpats,
nulljournal, nulljournal,
journalCheckBalanceAssertions, journalCheckBalanceAssertions,
journalNumberAndTieTransactions, journalNumberAndTieTransactions,
@ -301,7 +300,7 @@ journalAccountNameTree = accountNameTreeFrom . journalAccountNames
-- or otherwise for accounts with names matched by the case-insensitive -- or otherwise for accounts with names matched by the case-insensitive
-- regular expression @^assets?(:|$)@. -- regular expression @^assets?(:|$)@.
journalAssetAccountQuery :: Journal -> Query 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 -- | 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 -- 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 :: Journal -> Query
journalCashAccountQuery j = journalCashAccountQuery j =
case M.lookup Cash (jdeclaredaccounttypes j) of case M.lookup Cash (jdeclaredaccounttypes j) of
Nothing -> And [ journalAssetAccountQuery j, Not . Acct $ toRegex' "(investment|receivable|:A/R|:fixed)" ]
Just _ -> journalAccountTypeQuery [Cash] notused j Just _ -> journalAccountTypeQuery [Cash] notused j
where notused = error' "journalCashAccountQuery: this should not have happened!" -- PARTIAL: 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 -- | A query for accounts in this journal which have been
-- declared as Liability by account directives, or otherwise for -- declared as Liability by account directives, or otherwise for
-- accounts with names matched by the case-insensitive regular expression -- accounts with names matched by the case-insensitive regular expression
-- @^(debts?|liabilit(y|ies))(:|$)@. -- @^(debts?|liabilit(y|ies))(:|$)@.
journalLiabilityAccountQuery :: Journal -> Query 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 -- | A query for accounts in this journal which have been
-- declared as Equity by account directives, or otherwise for -- declared as Equity by account directives, or otherwise for
-- accounts with names matched by the case-insensitive regular expression -- accounts with names matched by the case-insensitive regular expression
-- @^equity(:|$)@. -- @^equity(:|$)@.
journalEquityAccountQuery :: Journal -> Query journalEquityAccountQuery :: Journal -> Query
journalEquityAccountQuery = journalAccountTypeQuery [Equity] "^equity(:|$)" journalEquityAccountQuery = journalAccountTypeQuery [Equity] (toRegex' "^equity(:|$)")
-- | A query for accounts in this journal which have been -- | A query for accounts in this journal which have been
-- declared as Revenue by account directives, or otherwise for -- declared as Revenue by account directives, or otherwise for
-- accounts with names matched by the case-insensitive regular expression -- accounts with names matched by the case-insensitive regular expression
-- @^(income|revenue)s?(:|$)@. -- @^(income|revenue)s?(:|$)@.
journalRevenueAccountQuery :: Journal -> Query 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 -- | A query for accounts in this journal which have been
-- declared as Expense by account directives, or otherwise for -- declared as Expense by account directives, or otherwise for
-- accounts with names matched by the case-insensitive regular expression -- accounts with names matched by the case-insensitive regular expression
-- @^expenses?(:|$)@. -- @^expenses?(:|$)@.
journalExpenseAccountQuery :: Journal -> Query journalExpenseAccountQuery :: Journal -> Query
journalExpenseAccountQuery = journalAccountTypeQuery [Expense] "^expenses?(:|$)" journalExpenseAccountQuery = journalAccountTypeQuery [Expense] (toRegex' "^expenses?(:|$)")
-- | A query for Asset, Liability & Equity accounts in this journal. -- | A query for Asset, Liability & Equity accounts in this journal.
-- Cf <http://en.wikipedia.org/wiki/Chart_of_accounts#Balance_Sheet_Accounts>. -- Cf <http://en.wikipedia.org/wiki/Chart_of_accounts#Balance_Sheet_Accounts>.
journalBalanceSheetAccountQuery :: Journal -> Query journalBalanceSheetAccountQuery :: Journal -> Query
journalBalanceSheetAccountQuery j = Or [journalAssetAccountQuery j journalBalanceSheetAccountQuery j = Or [journalAssetAccountQuery j
,journalLiabilityAccountQuery j ,journalLiabilityAccountQuery j
,journalEquityAccountQuery j ,journalEquityAccountQuery j
@ -370,17 +367,16 @@ journalAccountTypeQuery :: [AccountType] -> Regexp -> Journal -> Query
journalAccountTypeQuery atypes fallbackregex Journal{jdeclaredaccounttypes} = journalAccountTypeQuery atypes fallbackregex Journal{jdeclaredaccounttypes} =
let let
declaredacctsoftype :: [AccountName] = declaredacctsoftype :: [AccountName] =
concat $ catMaybes [M.lookup t jdeclaredaccounttypes | t <- atypes] concat $ mapMaybe (`M.lookup` jdeclaredaccounttypes) atypes
in case declaredacctsoftype of in case declaredacctsoftype of
[] -> Acct fallbackregex [] -> Acct fallbackregex
as -> as -> And [ Or acctnameRegexes, Not $ Or differentlyTypedRegexes ]
-- 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
]
where 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 differentlytypedsubs = concat
[subs | (t,bs) <- M.toList jdeclaredaccounttypes [subs | (t,bs) <- M.toList jdeclaredaccounttypes
, not $ t `elem` atypes , 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 -- debug helpers
-- traceAmountPrecision a = trace (show $ map (precision . acommodity) $ amounts a) a -- traceAmountPrecision a = trace (show $ map (precision . acommodity) $ amounts a) a
-- tracePostingsCommodities ps = trace (show $ map ((map (precision . acommodity) . amounts) . pamount) ps) ps -- tracePostingsCommodities ps = trace (show $ map ((map (precision . acommodity) . amounts) . pamount) ps) ps

7
hledger-lib/Hledger/Data/Ledger.hs
View File

@ -17,7 +17,6 @@ module Hledger.Data.Ledger (
,ledgerRootAccount ,ledgerRootAccount
,ledgerTopAccounts ,ledgerTopAccounts
,ledgerLeafAccounts ,ledgerLeafAccounts
,ledgerAccountsMatching
,ledgerPostings ,ledgerPostings
,ledgerDateSpan ,ledgerDateSpan
,ledgerCommodities ,ledgerCommodities
@ -26,8 +25,6 @@ module Hledger.Data.Ledger (
where where
import qualified Data.Map as M import qualified Data.Map as M
-- import Data.Text (Text)
import qualified Data.Text as T
import Safe (headDef) import Safe (headDef)
import Text.Printf import Text.Printf
@ -90,10 +87,6 @@ ledgerTopAccounts = asubs . head . laccounts
ledgerLeafAccounts :: Ledger -> [Account] ledgerLeafAccounts :: Ledger -> [Account]
ledgerLeafAccounts = filter (null.asubs) . laccounts 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. -- | List a ledger's postings, in the order parsed.
ledgerPostings :: Ledger -> [Posting] ledgerPostings :: Ledger -> [Posting]
ledgerPostings = journalPostings . ljournal ledgerPostings = journalPostings . ljournal

2
hledger-lib/Hledger/Data/Posting.hs
View File

@ -315,7 +315,7 @@ aliasReplace (BasicAlias old new) a
Right $ new <> T.drop (T.length old) a Right $ new <> T.drop (T.length old) a
| otherwise = Right a | otherwise = Right a
aliasReplace (RegexAlias re repl) 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 -- | Apply a specified valuation to this posting's amount, using the
-- provided price oracle, commodity styles, reference dates, and -- provided price oracle, commodity styles, reference dates, and

6
hledger-lib/Hledger/Data/Types.hs
View File

@ -166,7 +166,7 @@ data AccountAlias = BasicAlias AccountName AccountName
| RegexAlias Regexp Replacement | RegexAlias Regexp Replacement
deriving (Eq, Read, Show, Ord, Data, Generic, Typeable) 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) 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, -- any included journal files. The main file is first,
-- followed by any included files in the order encountered. -- followed by any included files in the order encountered.
,jlastreadtime :: ClockTime -- ^ when this journal was last read from its file(s) ,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 Data ClockTime
deriving instance Typeable ClockTime deriving instance Typeable ClockTime
deriving instance Generic ClockTime deriving instance Generic ClockTime
instance NFData ClockTime instance NFData ClockTime
instance NFData Journal -- instance NFData Journal
-- | A journal in the process of being parsed, not yet finalised. -- | A journal in the process of being parsed, not yet finalised.
-- The data is partial, and list fields are in reverse order. -- The data is partial, and list fields are in reverse order.

328
hledger-lib/Hledger/Query.hs
View File

@ -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 -- (may hide other deprecation warnings too). https://github.com/ndmitchell/safe/issues/26
{-# OPTIONS_GHC -Wno-warnings-deprecations #-} {-# OPTIONS_GHC -Wno-warnings-deprecations #-}
{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, ViewPatterns #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Hledger.Query ( module Hledger.Query (
-- * Query and QueryOpt -- * Query and QueryOpt
@ -42,20 +45,13 @@ module Hledger.Query (
inAccountQuery, inAccountQuery,
-- * matching -- * matching
matchesTransaction, matchesTransaction,
matchesTransaction_,
matchesPosting, matchesPosting,
matchesPosting_,
matchesAccount, matchesAccount,
matchesAccount_,
matchesMixedAmount, matchesMixedAmount,
matchesAmount, matchesAmount,
matchesAmount_,
matchesCommodity, matchesCommodity,
matchesCommodity_,
matchesTags, matchesTags,
matchesTags_,
matchesPriceDirective, matchesPriceDirective,
matchesPriceDirective_,
words'', words'',
prefixes, prefixes,
-- * tests -- * tests
@ -63,7 +59,7 @@ module Hledger.Query (
) )
where where
import Control.Arrow ((>>>)) import Control.Applicative ((<|>), liftA2, many, optional)
import Data.Data import Data.Data
import Data.Either import Data.Either
import Data.List import Data.List
@ -74,7 +70,7 @@ import Data.Monoid ((<>))
import qualified Data.Text as T import qualified Data.Text as T
import Data.Time.Calendar import Data.Time.Calendar
import Safe (readDef, readMay, maximumByMay, maximumMay, minimumMay) import Safe (readDef, readMay, maximumByMay, maximumMay, minimumMay)
import Text.Megaparsec import Text.Megaparsec (between, noneOf, sepBy)
import Text.Megaparsec.Char import Text.Megaparsec.Char
import Hledger.Utils hiding (words') import Hledger.Utils hiding (words')
@ -111,6 +107,14 @@ data Query = Any -- ^ always match
-- matching the regexp if provided, exists -- matching the regexp if provided, exists
deriving (Eq,Data,Typeable) 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 -- custom Show implementation to show strings more accurately, eg for debugging regexps
instance Show Query where instance Show Query where
show Any = "Any" show Any = "Any"
@ -273,11 +277,11 @@ parseQueryTerm d (T.stripPrefix "not:" -> Just s) =
Right (Left m) -> Right $ Left $ Not m Right (Left m) -> Right $ Left $ Not m
Right (Right _) -> Right $ Left Any -- not:somequeryoption will be ignored Right (Right _) -> Right $ Left Any -- not:somequeryoption will be ignored
Left err -> Left err Left err -> Left err
parseQueryTerm _ (T.stripPrefix "code:" -> Just s) = Right $ Left $ Code $ T.unpack s parseQueryTerm _ (T.stripPrefix "code:" -> Just s) = Left . Code <$> toRegexCI_ (T.unpack s)
parseQueryTerm _ (T.stripPrefix "desc:" -> Just s) = Right $ Left $ Desc $ T.unpack s parseQueryTerm _ (T.stripPrefix "desc:" -> Just s) = Left . Desc <$> toRegexCI_ (T.unpack s)
parseQueryTerm _ (T.stripPrefix "payee:" -> Just s) = Right $ Left $ Tag "payee" $ Just $ T.unpack s parseQueryTerm _ (T.stripPrefix "payee:" -> Just s) = Left <$> payeeTag (Just $ T.unpack s)
parseQueryTerm _ (T.stripPrefix "note:" -> Just s) = Right $ Left $ Tag "note" $ Just $ T.unpack s parseQueryTerm _ (T.stripPrefix "note:" -> Just s) = Left <$> noteTag (Just $ T.unpack s)
parseQueryTerm _ (T.stripPrefix "acct:" -> Just s) = Right $ Left $ Acct $ T.unpack s parseQueryTerm _ (T.stripPrefix "acct:" -> Just s) = Left . Acct <$> toRegexCI_ (T.unpack s)
parseQueryTerm d (T.stripPrefix "date2:" -> Just s) = parseQueryTerm d (T.stripPrefix "date2:" -> Just s) =
case parsePeriodExpr d s of Left e -> Left $ "\"date2:"++T.unpack s++"\" gave a "++showDateParseError e case parsePeriodExpr d s of Left e -> Left $ "\"date2:"++T.unpack s++"\" gave a "++showDateParseError e
Right (_,span) -> Right $ Left $ Date2 span Right (_,span) -> Right $ Left $ Date2 span
@ -295,8 +299,8 @@ parseQueryTerm _ (T.stripPrefix "depth:" -> Just s)
| otherwise = Left "depth: should have a positive number" | otherwise = Left "depth: should have a positive number"
where n = readDef 0 (T.unpack s) 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 "cur:" -> Just s) = Left . Sym <$> toRegexCI_ ('^' : 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 "tag:" -> Just s) = Left <$> parseTag s
parseQueryTerm _ "" = Right $ Left $ Any parseQueryTerm _ "" = Right $ Left $ Any
parseQueryTerm d s = parseQueryTerm d $ defaultprefix<>":"<>s parseQueryTerm d s = parseQueryTerm d $ defaultprefix<>":"<>s
@ -344,10 +348,12 @@ parseAmountQueryTerm amtarg =
parse :: T.Text -> T.Text -> Maybe Quantity parse :: T.Text -> T.Text -> Maybe Quantity
parse p s = (T.stripPrefix p . T.strip) s >>= readMay . filter (not.(==' ')) . T.unpack parse p s = (T.stripPrefix p . T.strip) s >>= readMay . filter (not.(==' ')) . T.unpack
parseTag :: T.Text -> (Regexp, Maybe Regexp) parseTag :: T.Text -> Either RegexError Query
parseTag s | "=" `T.isInfixOf` s = (T.unpack n, Just $ tail $ T.unpack v) parseTag s = do
| otherwise = (T.unpack s, Nothing) tag <- toRegexCI_ . T.unpack $ if T.null v then s else n
where (n,v) = T.break (=='=') s 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. -- | Parse the value part of a "status:" query, or return an error.
parseStatus :: T.Text -> Either String Status parseStatus :: T.Text -> Either String Status
@ -550,8 +556,8 @@ inAccount (QueryOptInAcct a:_) = Just (a,True)
-- Just looks at the first query option. -- Just looks at the first query option.
inAccountQuery :: [QueryOpt] -> Maybe Query inAccountQuery :: [QueryOpt] -> Maybe Query
inAccountQuery [] = Nothing inAccountQuery [] = Nothing
inAccountQuery (QueryOptInAcctOnly a : _) = Just $ Acct $ accountNameToAccountOnlyRegex a inAccountQuery (QueryOptInAcctOnly a : _) = Just . Acct $ accountNameToAccountOnlyRegex a
inAccountQuery (QueryOptInAcct a : _) = Just $ Acct $ accountNameToAccountRegex a inAccountQuery (QueryOptInAcct a : _) = Just . Acct $ accountNameToAccountRegex a
-- -- | Convert a query to its inverse. -- -- | Convert a query to its inverse.
-- negateQuery :: Query -> Query -- negateQuery :: Query -> Query
@ -568,36 +574,38 @@ matchesAccount (None) _ = False
matchesAccount (Not m) a = not $ matchesAccount m a matchesAccount (Not m) a = not $ matchesAccount m a
matchesAccount (Or ms) a = any (`matchesAccount` a) ms matchesAccount (Or ms) a = any (`matchesAccount` a) ms
matchesAccount (And ms) a = all (`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 (Depth d) a = accountNameLevel a <= d
matchesAccount (Tag _ _) _ = False matchesAccount (Tag _ _) _ = False
matchesAccount _ _ = True matchesAccount _ _ = True
-- | Total version of matchesAccount, which will return any error -- | Total version of matchesAccount, which will return any error
-- arising from a malformed regular expression in the query. -- arising from a malformed regular expression in the query.
matchesAccount_ :: Query -> AccountName -> Either RegexError Bool -- FIXME: unnecssary
matchesAccount_ (None) _ = Right False -- matchesAccount_ :: Query -> AccountName -> Either RegexError Bool
matchesAccount_ (Not m) a = Right $ not $ matchesAccount m a -- matchesAccount_ (None) _ = Right False
matchesAccount_ (Or ms) a = sequence (map (`matchesAccount_` a) ms) >>= pure . or -- matchesAccount_ (Not m) a = Right $ not $ matchesAccount m a
matchesAccount_ (And ms) a = sequence (map (`matchesAccount_` a) ms) >>= pure . and -- matchesAccount_ (Or ms) a = sequence (map (`matchesAccount_` a) ms) >>= pure . or
matchesAccount_ (Acct r) a = regexMatchesCI_ r (T.unpack a) -- XXX pack -- matchesAccount_ (And ms) a = sequence (map (`matchesAccount_` a) ms) >>= pure . and
matchesAccount_ (Depth d) a = Right $ accountNameLevel a <= d -- matchesAccount_ (Acct r) a = match r (T.unpack a) -- XXX pack
matchesAccount_ (Tag _ _) _ = Right False -- matchesAccount_ (Depth d) a = Right $ accountNameLevel a <= d
matchesAccount_ _ _ = Right True -- matchesAccount_ (Tag _ _) _ = Right False
-- matchesAccount_ _ _ = Right True
matchesMixedAmount :: Query -> MixedAmount -> Bool matchesMixedAmount :: Query -> MixedAmount -> Bool
matchesMixedAmount q (Mixed []) = q `matchesAmount` nullamt matchesMixedAmount q (Mixed []) = q `matchesAmount` nullamt
matchesMixedAmount q (Mixed as) = any (q `matchesAmount`) as matchesMixedAmount q (Mixed as) = any (q `matchesAmount`) as
matchesCommodity :: Query -> CommoditySymbol -> Bool matchesCommodity :: Query -> CommoditySymbol -> Bool
matchesCommodity (Sym r) s = regexMatchesCI ("^" ++ r ++ "$") (T.unpack s) matchesCommodity (Sym r) = match r . T.unpack
matchesCommodity _ _ = True matchesCommodity _ = const True
-- | Total version of matchesCommodity, which will return any error -- | Total version of matchesCommodity, which will return any error
-- arising from a malformed regular expression in the query. -- arising from a malformed regular expression in the query.
matchesCommodity_ :: Query -> CommoditySymbol -> Either RegexError Bool -- FIXME unnecessary
matchesCommodity_ (Sym r) s = regexMatchesCI_ ("^" ++ r ++ "$") (T.unpack s) -- matchesCommodity_ :: Query -> CommoditySymbol -> Bool
matchesCommodity_ _ _ = Right True -- matchesCommodity_ (Sym r) = match r . T.unpack
-- matchesCommodity_ _ = const True
-- | Does the match expression match this (simple) amount ? -- | Does the match expression match this (simple) amount ?
matchesAmount :: Query -> Amount -> Bool matchesAmount :: Query -> Amount -> Bool
@ -612,15 +620,16 @@ matchesAmount _ _ = True
-- | Total version of matchesAmount, returning any error from a -- | Total version of matchesAmount, returning any error from a
-- malformed regular expression in the query. -- malformed regular expression in the query.
matchesAmount_ :: Query -> Amount -> Either RegexError Bool -- FIXME Unnecessary
matchesAmount_ (Not q) a = not <$> q `matchesAmount_` a -- matchesAmount_ :: Query -> Amount -> Either RegexError Bool
matchesAmount_ (Any) _ = Right True -- matchesAmount_ (Not q) a = not <$> q `matchesAmount_` a
matchesAmount_ (None) _ = Right False -- matchesAmount_ (Any) _ = Right True
matchesAmount_ (Or qs) a = sequence (map (`matchesAmount_` a) qs) >>= pure . or -- matchesAmount_ (None) _ = Right False
matchesAmount_ (And qs) a = sequence (map (`matchesAmount_` a) qs) >>= pure . and -- matchesAmount_ (Or qs) a = sequence (map (`matchesAmount_` a) qs) >>= pure . or
matchesAmount_ (Amt ord n) a = Right $ compareAmount ord n a -- matchesAmount_ (And qs) a = sequence (map (`matchesAmount_` a) qs) >>= pure . and
matchesAmount_ (Sym r) a = matchesCommodity_ (Sym r) (acommodity a) -- matchesAmount_ (Amt ord n) a = Right $ compareAmount ord n a
matchesAmount_ _ _ = Right True -- 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 ? -- | 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. -- 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 (None) _ = False
matchesPosting (Or qs) p = any (`matchesPosting` p) qs matchesPosting (Or qs) p = any (`matchesPosting` p) qs
matchesPosting (And qs) p = all (`matchesPosting` p) qs matchesPosting (And qs) p = all (`matchesPosting` p) qs
matchesPosting (Code r) p = regexMatchesCI r $ maybe "" (T.unpack . tcode) $ ptransaction p matchesPosting (Code r) p = match r $ maybe "" (T.unpack . tcode) $ ptransaction p
matchesPosting (Desc r) p = regexMatchesCI r $ maybe "" (T.unpack . tdescription) $ ptransaction p matchesPosting (Desc r) p = match r $ maybe "" (T.unpack . tdescription) $ ptransaction p
matchesPosting (Acct r) p = matches p || matches (originalPosting 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 (Date span) p = span `spanContainsDate` postingDate p
matchesPosting (Date2 span) p = span `spanContainsDate` postingDate2 p matchesPosting (Date2 span) p = span `spanContainsDate` postingDate2 p
matchesPosting (StatusQ s) p = postingStatus p == s 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) Posting{pamount=a} = mixedAmountLooksZero a
matchesPosting (Empty _) _ = True matchesPosting (Empty _) _ = True
matchesPosting (Sym r) Posting{pamount=Mixed as} = any (matchesCommodity (Sym r)) $ map acommodity as matchesPosting (Sym r) Posting{pamount=Mixed as} = any (matchesCommodity (Sym r)) $ map acommodity as
matchesPosting (Tag n v) p = case (n, v) of matchesPosting (Tag n v) p = case (reString n, v) of
("payee", Just v) -> maybe False (regexMatchesCI v . T.unpack . transactionPayee) $ ptransaction p ("payee", Just v) -> maybe False (match v . T.unpack . transactionPayee) $ ptransaction p
("note", Just v) -> maybe False (regexMatchesCI v . T.unpack . transactionNote) $ ptransaction p ("note", Just v) -> maybe False (match v . T.unpack . transactionNote) $ ptransaction p
(n, v) -> matchesTags n v $ postingAllTags p (_, v) -> matchesTags n v $ postingAllTags p
-- | Total version of matchesPosting, returning any error from a -- | Total version of matchesPosting, returning any error from a
-- malformed regular expression in the query. -- malformed regular expression in the query.
matchesPosting_ :: Query -> Posting -> Either RegexError Bool -- -- FIXME: unnecessary
matchesPosting_ (Not q) p = not <$> q `matchesPosting_` p -- matchesPosting_ :: Query -> Posting -> Bool
matchesPosting_ (Any) _ = Right True -- matchesPosting_ (Not q) p = not <$> q `matchesPosting_` p
matchesPosting_ (None) _ = Right False -- matchesPosting_ (Any) _ = Right True
matchesPosting_ (Or qs) p = sequence (map (`matchesPosting_` p) qs) >>= pure.or -- matchesPosting_ (None) _ = Right False
matchesPosting_ (And qs) p = sequence (map (`matchesPosting_` p) qs) >>= pure.and -- matchesPosting_ (Or qs) p = sequence (map (`matchesPosting_` p) qs) >>= pure.or
matchesPosting_ (Code r) p = regexMatchesCI_ r $ maybe "" (T.unpack . tcode) $ ptransaction p -- matchesPosting_ (And qs) p = sequence (map (`matchesPosting_` p) qs) >>= pure.and
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_ (Acct r) p = sequence [matches p, matches (originalPosting p)] >>= pure.or -- matchesPosting_ (Desc r) p = match r $ maybe "" (T.unpack . tdescription) $ ptransaction p
where matches p = regexMatchesCI_ r $ T.unpack $ paccount p -- XXX pack -- matchesPosting_ (Acct r) p = sequence [matches p, matches (originalPosting p)] >>= pure.or
matchesPosting_ (Date span) p = Right $ span `spanContainsDate` postingDate p -- where matches p = match r $ T.unpack $ paccount p -- XXX pack
matchesPosting_ (Date2 span) p = Right $ span `spanContainsDate` postingDate2 p -- matchesPosting_ (Date span) p = Right $ span `spanContainsDate` postingDate p
matchesPosting_ (StatusQ s) p = Right $ postingStatus p == s -- matchesPosting_ (Date2 span) p = Right $ span `spanContainsDate` postingDate2 p
matchesPosting_ (Real v) p = Right $ v == isReal p -- matchesPosting_ (StatusQ s) p = Right $ postingStatus p == s
matchesPosting_ q@(Depth _) Posting{paccount=a} = q `matchesAccount_` a -- matchesPosting_ (Real v) p = Right $ v == isReal p
matchesPosting_ q@(Amt _ _) Posting{pamount=amt} = Right $ q `matchesMixedAmount` amt -- matchesPosting_ q@(Depth _) Posting{paccount=a} = q `matchesAccount_` a
matchesPosting_ (Empty _) _ = Right True -- matchesPosting_ q@(Amt _ _) Posting{pamount=amt} = Right $ q `matchesMixedAmount` amt
matchesPosting_ (Sym r) Posting{pamount=Mixed as} = sequence (map (matchesCommodity_ (Sym r)) $ map acommodity as) >>= pure.or -- matchesPosting_ (Empty _) _ = Right True
matchesPosting_ (Tag n v) p = case (n, v) of -- matchesPosting_ (Sym r) Posting{pamount=Mixed as} = sequence (map (matchesCommodity_ (Sym r)) $ map acommodity as) >>= pure.or
("payee", Just v) -> maybe (Right False) (T.unpack . transactionPayee >>> regexMatchesCI_ v) $ ptransaction p -- matchesPosting_ (Tag n v) p = case (n, v) of
("note", Just v) -> maybe (Right False) (T.unpack . transactionNote >>> regexMatchesCI_ v) $ ptransaction p -- ("payee", Just v) -> maybe (Right False) (T.unpack . transactionPayee >>> match v) $ ptransaction p
(n, v) -> matchesTags_ n v $ postingAllTags 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 ? -- | Does the match expression match this transaction ?
matchesTransaction :: Query -> Transaction -> Bool matchesTransaction :: Query -> Transaction -> Bool
@ -700,8 +710,8 @@ matchesTransaction (Any) _ = True
matchesTransaction (None) _ = False matchesTransaction (None) _ = False
matchesTransaction (Or qs) t = any (`matchesTransaction` t) qs matchesTransaction (Or qs) t = any (`matchesTransaction` t) qs
matchesTransaction (And qs) t = all (`matchesTransaction` t) qs matchesTransaction (And qs) t = all (`matchesTransaction` t) qs
matchesTransaction (Code r) t = regexMatchesCI r $ T.unpack $ tcode t matchesTransaction (Code r) t = match r $ T.unpack $ tcode t
matchesTransaction (Desc r) t = regexMatchesCI r $ T.unpack $ tdescription t matchesTransaction (Desc r) t = match r $ T.unpack $ tdescription t
matchesTransaction q@(Acct _) t = any (q `matchesPosting`) $ tpostings t matchesTransaction q@(Acct _) t = any (q `matchesPosting`) $ tpostings t
matchesTransaction (Date span) t = spanContainsDate span $ tdate t matchesTransaction (Date span) t = spanContainsDate span $ tdate t
matchesTransaction (Date2 span) t = spanContainsDate span $ transactionDate2 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 (Empty _) _ = True
matchesTransaction (Depth d) t = any (Depth d `matchesPosting`) $ tpostings t matchesTransaction (Depth d) t = any (Depth d `matchesPosting`) $ tpostings t
matchesTransaction q@(Sym _) t = any (q `matchesPosting`) $ tpostings t matchesTransaction q@(Sym _) t = any (q `matchesPosting`) $ tpostings t
matchesTransaction (Tag n v) t = case (n, v) of matchesTransaction (Tag n v) t = case (reString n, v) of
("payee", Just v) -> regexMatchesCI v . T.unpack . transactionPayee $ t ("payee", Just v) -> match v . T.unpack . transactionPayee $ t
("note", Just v) -> regexMatchesCI v . T.unpack . transactionNote $ t ("note", Just v) -> match v . T.unpack . transactionNote $ t
(n, v) -> matchesTags n v $ transactionAllTags t (_, v) -> matchesTags n v $ transactionAllTags t
-- | Total version of matchesTransaction, returning any error from a -- | Total version of matchesTransaction, returning any error from a
-- malformed regular expression in the query. -- malformed regular expression in the query.
matchesTransaction_ :: Query -> Transaction -> Either RegexError Bool -- FIXME: unnecessary
matchesTransaction_ (Not q) t = not <$> q `matchesTransaction_` t -- matchesTransaction_ :: Query -> Transaction -> Either RegexError Bool
matchesTransaction_ (Any) _ = Right True -- matchesTransaction_ (Not q) t = not <$> q `matchesTransaction_` t
matchesTransaction_ (None) _ = Right False -- matchesTransaction_ (Any) _ = Right True
matchesTransaction_ (Or qs) t = sequence (map (`matchesTransaction_` t) qs) >>= pure.or -- matchesTransaction_ (None) _ = Right False
matchesTransaction_ (And qs) t = sequence (map (`matchesTransaction_` t) qs) >>= pure.and -- matchesTransaction_ (Or qs) t = sequence (map (`matchesTransaction_` t) qs) >>= pure.or
matchesTransaction_ (Code r) t = regexMatchesCI_ r $ T.unpack $ tcode t -- matchesTransaction_ (And qs) t = sequence (map (`matchesTransaction_` t) qs) >>= pure.and
matchesTransaction_ (Desc r) t = regexMatchesCI_ r $ T.unpack $ tdescription t -- matchesTransaction_ (Code r) t = match r $ T.unpack $ tcode t
matchesTransaction_ q@(Acct _) t = sequence (map (q `matchesPosting_`) $ tpostings t) >>= pure.or -- matchesTransaction_ (Desc r) t = match r $ T.unpack $ tdescription t
matchesTransaction_ (Date span) t = Right $ spanContainsDate span $ tdate t -- matchesTransaction_ q@(Acct _) t = sequence (map (q `matchesPosting_`) $ tpostings t) >>= pure.or
matchesTransaction_ (Date2 span) t = Right $ spanContainsDate span $ transactionDate2 t -- matchesTransaction_ (Date span) t = Right $ spanContainsDate span $ tdate t
matchesTransaction_ (StatusQ s) t = Right $ tstatus t == s -- matchesTransaction_ (Date2 span) t = Right $ spanContainsDate span $ transactionDate2 t
matchesTransaction_ (Real v) t = Right $ v == hasRealPostings t -- matchesTransaction_ (StatusQ s) t = Right $ tstatus t == s
matchesTransaction_ q@(Amt _ _) t = sequence (map (q `matchesPosting_`) $ tpostings t) >>= pure.or -- matchesTransaction_ (Real v) t = Right $ v == hasRealPostings t
matchesTransaction_ (Empty _) _ = Right True -- matchesTransaction_ q@(Amt _ _) t = sequence (map (q `matchesPosting_`) $ tpostings t) >>= pure.or
matchesTransaction_ (Depth d) t = sequence (map (Depth d `matchesPosting_`) $ tpostings t) >>= pure.or -- matchesTransaction_ (Empty _) _ = Right True
matchesTransaction_ q@(Sym _) t = sequence (map (q `matchesPosting_`) $ tpostings t) >>= pure.or -- matchesTransaction_ (Depth d) t = sequence (map (Depth d `matchesPosting_`) $ tpostings t) >>= pure.or
matchesTransaction_ (Tag n v) t = case (n, v) of -- matchesTransaction_ q@(Sym _) t = sequence (map (q `matchesPosting_`) $ tpostings t) >>= pure.or
("payee", Just v) -> regexMatchesCI_ v . T.unpack . transactionPayee $ t -- matchesTransaction_ (Tag n v) t = case (n, v) of
("note", Just v) -> regexMatchesCI_ v . T.unpack . transactionNote $ t -- ("payee", Just v) -> match v . T.unpack . transactionPayee $ t
(n, v) -> matchesTags_ n v $ transactionAllTags 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 ? -- | Does the query match the name and optionally the value of any of these tags ?
matchesTags :: Regexp -> Maybe Regexp -> [Tag] -> Bool 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 where
match npat Nothing (n,_) = regexMatchesCI npat (T.unpack n) -- XXX matches npat vpat (n,v) = match npat (T.unpack n) && maybe (const True) match vpat (T.unpack v)
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
-- | Does the query match this market price ? -- | Does the query match this market price ?
matchesPriceDirective :: Query -> PriceDirective -> Bool matchesPriceDirective :: Query -> PriceDirective -> Bool
@ -770,38 +770,39 @@ matchesPriceDirective _ _ = True
-- | Total version of matchesPriceDirective, returning any error from -- | Total version of matchesPriceDirective, returning any error from
-- a malformed regular expression in the query. -- a malformed regular expression in the query.
matchesPriceDirective_ :: Query -> PriceDirective -> Either RegexError Bool -- FIXME unnecessary
matchesPriceDirective_ (None) _ = Right False -- matchesPriceDirective_ :: Query -> PriceDirective -> Either RegexError Bool
matchesPriceDirective_ (Not q) p = not <$> matchesPriceDirective_ q p -- matchesPriceDirective_ (None) _ = Right False
matchesPriceDirective_ (Or qs) p = sequence (map (`matchesPriceDirective_` p) qs) >>= pure.or -- matchesPriceDirective_ (Not q) p = not <$> matchesPriceDirective_ q p
matchesPriceDirective_ (And qs) p = sequence (map (`matchesPriceDirective_` p) qs) >>= pure.and -- matchesPriceDirective_ (Or qs) p = sequence (map (`matchesPriceDirective_` p) qs) >>= pure.or
matchesPriceDirective_ q@(Amt _ _) p = matchesAmount_ q (pdamount p) -- matchesPriceDirective_ (And qs) p = sequence (map (`matchesPriceDirective_` p) qs) >>= pure.and
matchesPriceDirective_ q@(Sym _) p = matchesCommodity_ q (pdcommodity p) -- matchesPriceDirective_ q@(Amt _ _) p = matchesAmount_ q (pdamount p)
matchesPriceDirective_ (Date span) p = Right $ spanContainsDate span (pddate p) -- matchesPriceDirective_ q@(Sym _) p = matchesCommodity_ q (pdcommodity p)
matchesPriceDirective_ _ _ = Right True -- matchesPriceDirective_ (Date span) p = Right $ spanContainsDate span (pddate p)
-- matchesPriceDirective_ _ _ = Right True
-- tests -- tests
tests_Query = tests "Query" [ tests_Query = tests "Query" [
test "simplifyQuery" $ do test "simplifyQuery" $ do
(simplifyQuery $ Or [Acct "a"]) @?= (Acct "a") (simplifyQuery $ Or [Acct $ toRegex' "a"]) @?= (Acct $ toRegex' "a")
(simplifyQuery $ Or [Any,None]) @?= (Any) (simplifyQuery $ Or [Any,None]) @?= (Any)
(simplifyQuery $ And [Any,None]) @?= (None) (simplifyQuery $ And [Any,None]) @?= (None)
(simplifyQuery $ And [Any,Any]) @?= (Any) (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 [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)]) (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))) @?= (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 ,test "parseQuery" $ do
(parseQuery nulldate "acct:'expenses:autres d\233penses' desc:b") @?= Right (And [Acct "expenses:autres d\233penses", Desc "b"], []) (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 "b b", [QueryOptInAcct "a"]) 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 "inacct:a inacct:b" @?= Right (Any, [QueryOptInAcct "a", QueryOptInAcct "b"])
parseQuery nulldate "desc:'x x'" @?= Right (Desc "x x", []) parseQuery nulldate "desc:'x x'" @?= Right (Desc $ toRegexCI' "x x", [])
parseQuery nulldate "'a a' 'b" @?= Right (Or [Acct "a a",Acct "'b"], []) parseQuery nulldate "'a a' 'b" @?= Right (Or [Acct $ toRegexCI' "a a",Acct $ toRegexCI' "'b"], [])
parseQuery nulldate "\"" @?= Right (Acct "\"", []) parseQuery nulldate "\"" @?= Right (Acct $ toRegexCI' "\"", [])
,test "words''" $ do ,test "words''" $ do
(words'' [] "a b") @?= ["a","b"] (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 filterQuery queryIsDepth (And [Date nulldatespan, Not (Or [Any, Depth 1])]) @?= Any -- XXX unclear
,test "parseQueryTerm" $ do ,test "parseQueryTerm" $ do
parseQueryTerm nulldate "a" @?= Right (Left $ Acct "a") parseQueryTerm nulldate "a" @?= Right (Left $ Acct $ toRegexCI' "a")
parseQueryTerm nulldate "acct:expenses:autres d\233penses" @?= Right (Left $ Acct "expenses:autres d\233penses") 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 "a b") parseQueryTerm nulldate "not:desc:a b" @?= Right (Left $ Not $ Desc $ toRegexCI' "a b")
parseQueryTerm nulldate "status:1" @?= Right (Left $ StatusQ Cleared) parseQueryTerm nulldate "status:1" @?= Right (Left $ StatusQ Cleared)
parseQueryTerm nulldate "status:*" @?= Right (Left $ StatusQ Cleared) parseQueryTerm nulldate "status:*" @?= Right (Left $ StatusQ Cleared)
parseQueryTerm nulldate "status:!" @?= Right (Left $ StatusQ Pending) parseQueryTerm nulldate "status:!" @?= Right (Left $ StatusQ Pending)
parseQueryTerm nulldate "status:0" @?= Right (Left $ StatusQ Unmarked) parseQueryTerm nulldate "status:0" @?= Right (Left $ StatusQ Unmarked)
parseQueryTerm nulldate "status:" @?= Right (Left $ StatusQ Unmarked) parseQueryTerm nulldate "status:" @?= Right (Left $ StatusQ Unmarked)
parseQueryTerm nulldate "payee:x" @?= Right (Left $ Tag "payee" (Just "x")) parseQueryTerm nulldate "payee:x" @?= Left <$> payeeTag (Just "x")
parseQueryTerm nulldate "note:x" @?= Right (Left $ Tag "note" (Just "x")) parseQueryTerm nulldate "note:x" @?= Left <$> noteTag (Just "x")
parseQueryTerm nulldate "real:1" @?= Right (Left $ Real True) 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: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: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 "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 "inacct:a" @?= Right (Right $ QueryOptInAcct "a")
parseQueryTerm nulldate "tag:a" @?= Right (Left $ Tag "a" Nothing) parseQueryTerm nulldate "tag:a" @?= Right (Left $ Tag (toRegexCI' "a") Nothing)
parseQueryTerm nulldate "tag:a=some value" @?= Right (Left $ Tag "a" (Just "some value")) 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:<0" @?= Right (Left $ Amt Lt 0)
parseQueryTerm nulldate "amt:>10000.10" @?= Right (Left $ Amt AbsGt 10000.1) 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 queryEndDate False (Or [Date $ DateSpan Nothing small, Date $ DateSpan Nothing Nothing]) @?= Nothing
,test "matchesAccount" $ do ,test "matchesAccount" $ do
assertBool "" $ (Acct "b:c") `matchesAccount` "a:bb:c:d" assertBool "" $ (Acct $ toRegex' "b:c") `matchesAccount` "a:bb:c:d"
assertBool "" $ not $ (Acct "^a:b") `matchesAccount` "c:a:b" assertBool "" $ not $ (Acct $ toRegex' "^a:b") `matchesAccount` "c:a:b"
assertBool "" $ Depth 2 `matchesAccount` "a" assertBool "" $ Depth 2 `matchesAccount` "a"
assertBool "" $ Depth 2 `matchesAccount` "a:b" assertBool "" $ Depth 2 `matchesAccount` "a:b"
assertBool "" $ not $ Depth 2 `matchesAccount` "a:b:c" assertBool "" $ not $ Depth 2 `matchesAccount` "a:b:c"
assertBool "" $ Date nulldatespan `matchesAccount` "a" assertBool "" $ Date nulldatespan `matchesAccount` "a"
assertBool "" $ Date2 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" [ ,tests "matchesPosting" [
test "positive match on cleared posting status" $ 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 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 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 "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 ,test "tag:" $ do
assertBool "" $ not $ (Tag "a" (Just "r$")) `matchesPosting` nullposting assertBool "" $ not $ (Tag (toRegex' "a") (Just $ toRegex' "r$")) `matchesPosting` nullposting
assertBool "" $ (Tag "foo" Nothing) `matchesPosting` nullposting{ptags=[("foo","")]} assertBool "" $ (Tag (toRegex' "foo") Nothing) `matchesPosting` nullposting{ptags=[("foo","")]}
assertBool "" $ (Tag "foo" Nothing) `matchesPosting` nullposting{ptags=[("foo","baz")]} assertBool "" $ (Tag (toRegex' "foo") Nothing) `matchesPosting` nullposting{ptags=[("foo","baz")]}
assertBool "" $ (Tag "foo" (Just "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]} assertBool "" $ (Tag (toRegex' "foo") (Just $ toRegex' "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]}
assertBool "" $ not $ (Tag "foo" (Just "a$")) `matchesPosting` nullposting{ptags=[("foo","bar")]} assertBool "" $ not $ (Tag (toRegex' "foo") (Just $ toRegex' "a$")) `matchesPosting` nullposting{ptags=[("foo","bar")]}
assertBool "" $ not $ (Tag " foo " (Just "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]} assertBool "" $ not $ (Tag (toRegex' " foo ") (Just $ toRegex' "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]}
assertBool "" $ not $ (Tag "foo foo" (Just " ar ba ")) `matchesPosting` nullposting{ptags=[("foo foo","bar 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 "txntag" Nothing) `matchesPosting` nullposting{ptransaction=Just nulltransaction{ttags=[("txntag","")]}} ,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 ,test "cur:" $ do
assertBool "" $ not $ (Sym "$") `matchesPosting` nullposting{pamount=Mixed [usd 1]} -- becomes "^$$", ie testing for null symbol let toSym = either id (const $ error' "No query opts") . either error' id . parseQueryTerm (fromGregorian 2000 01 01) . ("cur:"<>)
assertBool "" $ (Sym "\\$") `matchesPosting` nullposting{pamount=Mixed [usd 1]} -- have to quote $ for regexpr assertBool "" $ not $ toSym "$" `matchesPosting` nullposting{pamount=Mixed [usd 1]} -- becomes "^$$", ie testing for null symbol
assertBool "" $ (Sym "shekels") `matchesPosting` nullposting{pamount=Mixed [nullamt{acommodity="shekels"}]} assertBool "" $ (toSym "\\$") `matchesPosting` nullposting{pamount=Mixed [usd 1]} -- have to quote $ for regexpr
assertBool "" $ not $ (Sym "shek") `matchesPosting` nullposting{pamount=Mixed [nullamt{acommodity="shekels"}]} assertBool "" $ (toSym "shekels") `matchesPosting` nullposting{pamount=Mixed [nullamt{acommodity="shekels"}]}
assertBool "" $ not $ (toSym "shek") `matchesPosting` nullposting{pamount=Mixed [nullamt{acommodity="shekels"}]}
] ]
,test "matchesTransaction" $ do ,test "matchesTransaction" $ do
assertBool "" $ Any `matchesTransaction` nulltransaction assertBool "" $ Any `matchesTransaction` nulltransaction
assertBool "" $ not $ (Desc "x x") `matchesTransaction` nulltransaction{tdescription="x"} assertBool "" $ not $ (Desc $ toRegex' "x x") `matchesTransaction` nulltransaction{tdescription="x"}
assertBool "" $ (Desc "x x") `matchesTransaction` nulltransaction{tdescription="x x"} assertBool "" $ (Desc $ toRegex' "x x") `matchesTransaction` nulltransaction{tdescription="x x"}
-- see posting for more tag tests -- see posting for more tag tests
assertBool "" $ (Tag "foo" (Just "a")) `matchesTransaction` nulltransaction{ttags=[("foo","bar")]} assertBool "" $ (Tag (toRegex' "foo") (Just $ toRegex' "a")) `matchesTransaction` nulltransaction{ttags=[("foo","bar")]}
assertBool "" $ (Tag "payee" (Just "payee")) `matchesTransaction` nulltransaction{tdescription="payee|note"} assertBool "" $ (Tag (toRegex' "payee") (Just $ toRegex' "payee")) `matchesTransaction` nulltransaction{tdescription="payee|note"}
assertBool "" $ (Tag "note" (Just "note")) `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 -- 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","")]}]}
] ]

2
hledger-lib/Hledger/Read/Common.hs
View File

@ -144,7 +144,7 @@ import Text.Megaparsec.Custom
import Control.Applicative.Permutations import Control.Applicative.Permutations
import Hledger.Data import Hledger.Data
import Hledger.Utils import Hledger.Utils hiding (match)
--- ** doctest setup --- ** doctest setup
-- $setup -- $setup

50
hledger-lib/Hledger/Read/CsvReader.hs
View File

@ -44,6 +44,7 @@ import "base-compat-batteries" Prelude.Compat hiding (fail)
import Control.Exception (IOException, handle, throw) import Control.Exception (IOException, handle, throw)
import Control.Monad (liftM, unless, when) import Control.Monad (liftM, unless, when)
import Control.Monad.Except (ExceptT, throwError) import Control.Monad.Except (ExceptT, throwError)
import qualified Control.Monad.Fail as Fail
import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.State.Strict (StateT, get, modify', evalStateT) import Control.Monad.State.Strict (StateT, get, modify', evalStateT)
import Control.Monad.Trans.Class (lift) 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 as B
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import Data.Foldable import Data.Foldable
import Text.Megaparsec hiding (parse) import Text.Megaparsec hiding (match, parse)
import Text.Megaparsec.Char import Text.Megaparsec.Char
import Text.Megaparsec.Custom import Text.Megaparsec.Custom
import Text.Printf (printf) import Text.Printf (printf)
@ -294,17 +295,14 @@ type FieldTemplate = String
-- | A strptime date parsing pattern, as supported by Data.Time.Format. -- | A strptime date parsing pattern, as supported by Data.Time.Format.
type DateFormat = String type DateFormat = String
-- | A regular expression.
type RegexpPattern = String
-- | A prefix for a matcher test, either & or none (implicit or). -- | A prefix for a matcher test, either & or none (implicit or).
data MatcherPrefix = And | None data MatcherPrefix = And | None
deriving (Show, Eq) deriving (Show, Eq)
-- | A single test for matching a CSV record, in one way or another. -- | A single test for matching a CSV record, in one way or another.
data Matcher = data Matcher =
RecordMatcher MatcherPrefix RegexpPattern -- ^ match if this regexp matches the overall CSV record RecordMatcher MatcherPrefix Regexp -- ^ match if this regexp matches the overall CSV record
| FieldMatcher MatcherPrefix CsvFieldReference RegexpPattern -- ^ match if this regexp matches the referenced CSV field's value | FieldMatcher MatcherPrefix CsvFieldReference Regexp -- ^ match if this regexp matches the referenced CSV field's value
deriving (Show, Eq) deriving (Show, Eq)
-- | A conditional block: a set of CSV record matchers, and a sequence -- | 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) -- _ <- optional (matchoperatorp >> lift skipNonNewlineSpaces >> optional newline)
p <- matcherprefixp p <- matcherprefixp
r <- regexp end r <- regexp end
return $ RecordMatcher p r
-- when (null ps) $ -- when (null ps) $
-- Fail.fail "start of record matcher found, but no patterns afterward\n(patterns should not be indented)\n" -- Fail.fail "start of record matcher found, but no patterns afterward\n(patterns should not be indented)\n"
return $ RecordMatcher p r
<?> "record matcher" <?> "record matcher"
-- | A single matcher for a specific field. A csv field reference -- | A single matcher for a specific field. A csv field reference
@ -656,13 +654,15 @@ csvfieldreferencep = do
return $ '%' : quoteIfNeeded f return $ '%' : quoteIfNeeded f
-- A single regular expression -- A single regular expression
regexp :: CsvRulesParser () -> CsvRulesParser RegexpPattern regexp :: CsvRulesParser () -> CsvRulesParser Regexp
regexp end = do regexp end = do
lift $ dbgparse 8 "trying regexp" lift $ dbgparse 8 "trying regexp"
-- notFollowedBy matchoperatorp -- notFollowedBy matchoperatorp
c <- lift nonspace c <- lift nonspace
cs <- anySingle `manyTill` end 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. -- -- A match operator, indicating the type of match to perform.
-- -- Currently just ~ meaning case insensitive infix regex match. -- -- Currently just ~ meaning case insensitive infix regex match.
@ -1181,7 +1181,7 @@ getEffectiveAssignment rules record f = lastMay $ map snd $ assignments
where where
-- does this individual matcher match the current csv record ? -- does this individual matcher match the current csv record ?
matcherMatches :: Matcher -> Bool matcherMatches :: Matcher -> Bool
matcherMatches (RecordMatcher _ pat) = regexMatchesCI pat' wholecsvline matcherMatches (RecordMatcher _ pat) = match pat' wholecsvline
where where
pat' = dbg7 "regex" pat pat' = dbg7 "regex" pat
-- A synthetic whole CSV record to match against. Note, this can be -- 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 -- - and the field separator is always comma
-- which means that a field containing a comma will look like two fields. -- which means that a field containing a comma will look like two fields.
wholecsvline = dbg7 "wholecsvline" $ intercalate "," record wholecsvline = dbg7 "wholecsvline" $ intercalate "," record
matcherMatches (FieldMatcher _ csvfieldref pat) = regexMatchesCI pat csvfieldvalue matcherMatches (FieldMatcher _ csvfieldref pat) = match pat csvfieldvalue
where where
-- the value of the referenced CSV field to match against. -- the value of the referenced CSV field to match against.
csvfieldvalue = dbg7 "csvfieldvalue" $ replaceCsvFieldReference rules record csvfieldref 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 -- | Render a field assignment's template, possibly interpolating referenced
-- CSV field values. Outer whitespace is removed from interpolated values. -- CSV field values. Outer whitespace is removed from interpolated values.
renderTemplate :: CsvRules -> CsvRecord -> FieldTemplate -> String 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) -- | 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 -- 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" $ ,test "assignment with empty value" $
parseWithState' defrules rulesp "account1 \nif foo\n account2 foo\n" @?= 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" [ ,tests "conditionalblockp" [
test "space after conditional" $ -- #1120 test "space after conditional" $ -- #1120
parseWithState' defrules conditionalblockp "if a\n account2 b\n \n" @?= 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" [ ,tests "csvfieldreferencep" [
test "number" $ parseWithState' defrules csvfieldreferencep "%1" @?= (Right "%1") test "number" $ parseWithState' defrules csvfieldreferencep "%1" @?= (Right "%1")
@ -1272,19 +1272,19 @@ tests_CsvReader = tests "CsvReader" [
,tests "matcherp" [ ,tests "matcherp" [
test "recordmatcherp" $ 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-&" $ ,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-%" $ ,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" $ ,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-&" $ ,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" $ -- ,test "fieldmatcherp with operator" $
-- parseWithState' defrules matcherp "%description ~ A A\n" @?= (Right $ FieldMatcher "%description" "A A") -- parseWithState' defrules matcherp "%description ~ A A\n" @?= (Right $ FieldMatcher "%description" "A A")
@ -1293,22 +1293,22 @@ tests_CsvReader = tests "CsvReader" [
,tests "getEffectiveAssignment" [ ,tests "getEffectiveAssignment" [
let rules = mkrules $ defrules {rcsvfieldindexes=[("csvdate",1)],rassignments=[("date","%csvdate")]} let rules = mkrules $ defrules {rcsvfieldindexes=[("csvdate",1)],rassignments=[("date","%csvdate")]}
in test "toplevel" $ getEffectiveAssignment rules ["a","b"] "date" @?= (Just "%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") 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") 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") 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") 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") in test "conditional.with-and-or" $ getEffectiveAssignment rules ["_", "c"] "date" @?= (Just "%csvdate")
] ]

4
hledger-lib/Hledger/Read/JournalReader.hs
View File

@ -529,8 +529,8 @@ regexaliasp = do
char '=' char '='
skipNonNewlineSpaces skipNonNewlineSpaces
repl <- anySingle `manyTill` eolof repl <- anySingle `manyTill` eolof
case toRegex_ re of case toRegexCI_ re of
Right _ -> return $! RegexAlias re repl Right r -> return $! RegexAlias r repl
Left e -> customFailure $! parseErrorAtRegion off1 off2 e Left e -> customFailure $! parseErrorAtRegion off1 off2 e
endaliasesdirectivep :: JournalParser m () endaliasesdirectivep :: JournalParser m ()

2
hledger-lib/Hledger/Reports/EntriesReport.hs
View File

@ -50,7 +50,7 @@ entriesReport ropts@ReportOpts{..} q j@Journal{..} =
tests_EntriesReport = tests "EntriesReport" [ tests_EntriesReport = 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 ,test "date" $ (length $ entriesReport defreportopts (Date $ DateSpan (Just $ fromGregorian 2008 06 01) (Just $ fromGregorian 2008 07 01)) samplejournal) @?= 3
] ]
] ]

6
hledger-lib/Hledger/Reports/PostingsReport.hs
View File

@ -277,13 +277,13 @@ tests_PostingsReport = tests "PostingsReport" [
(Any, samplejournal) `gives` 13 (Any, samplejournal) `gives` 13
-- register --depth just clips account names -- register --depth just clips account names
(Depth 2, samplejournal) `gives` 13 (Depth 2, samplejournal) `gives` 13
(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 "expenses"], samplejournal) `gives` 2 (And [And [Depth 1, StatusQ Cleared], Acct (toRegex' "expenses")], samplejournal) `gives` 2
-- with query and/or command-line options -- with query and/or command-line options
(length $ snd $ postingsReport defreportopts Any samplejournal) @?= 13 (length $ snd $ postingsReport defreportopts Any samplejournal) @?= 13
(length $ snd $ postingsReport defreportopts{interval_=Months 1} Any samplejournal) @?= 11 (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{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 -- (defreportopts, And [Acct "a a", Acct "'b"], samplejournal2) `gives` 0
-- [(Just (fromGregorian 2008 01 01,"income"),assets:bank:checking $1,$1) -- [(Just (fromGregorian 2008 01 01,"income"),assets:bank:checking $1,$1)

17
hledger-lib/Hledger/Reports/ReportOptions.hs
View File

@ -346,7 +346,7 @@ forecastPeriodFromRawOpts d opts =
Just str -> Just str ->
either (\e -> usageError $ "could not parse forecast period : "++customErrorBundlePretty e) (Just . snd) $ either (\e -> usageError $ "could not parse forecast period : "++customErrorBundlePretty e) (Just . snd) $
parsePeriodExpr d $ stripquotes $ T.pack str parsePeriodExpr d $ stripquotes $ T.pack str
-- | Extract the interval from the parsed -p/--period expression. -- | Extract the interval from the parsed -p/--period expression.
-- Return Nothing if an interval is not explicitly defined. -- Return Nothing if an interval is not explicitly defined.
extractIntervalOrNothing :: (Interval, DateSpan) -> Maybe Interval extractIntervalOrNothing :: (Interval, DateSpan) -> Maybe Interval
@ -423,10 +423,10 @@ type DisplayExp = String
maybedisplayopt :: Day -> RawOpts -> Maybe DisplayExp maybedisplayopt :: Day -> RawOpts -> Maybe DisplayExp
maybedisplayopt d rawopts = maybedisplayopt d rawopts =
maybe Nothing (Just . regexReplaceBy "\\[.+?\\]" fixbracketeddatestr) $ maybestringopt "display" rawopts maybe Nothing (Just . replaceAllBy (toRegex' "\\[.+?\\]") fixbracketeddatestr) $ maybestringopt "display" rawopts
where where
fixbracketeddatestr "" = "" fixbracketeddatestr "" = ""
fixbracketeddatestr s = "[" ++ fixSmartDateStr d (T.pack $ init $ tail s) ++ "]" fixbracketeddatestr s = "[" ++ fixSmartDateStr d (T.pack $ init $ tail s) ++ "]"
-- | Select the Transaction date accessor based on --date2. -- | Select the Transaction date accessor based on --date2.
transactionDateFn :: ReportOpts -> (Transaction -> Day) transactionDateFn :: ReportOpts -> (Transaction -> Day)
@ -573,12 +573,12 @@ reportPeriodOrJournalLastDay ropts j =
tests_ReportOptions = tests "ReportOptions" [ tests_ReportOptions = tests "ReportOptions" [
test "queryFromOpts" $ do test "queryFromOpts" $ do
queryFromOpts nulldate defreportopts @?= Any queryFromOpts nulldate defreportopts @?= Any
queryFromOpts nulldate defreportopts{query_="a"} @?= Acct "a" queryFromOpts nulldate defreportopts{query_="a"} @?= Acct (toRegexCI' "a")
queryFromOpts nulldate defreportopts{query_="desc:'a a'"} @?= Desc "a 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'" } 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)) @?= (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_="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 ,test "queryOptsFromOpts" $ do
queryOptsFromOpts nulldate defreportopts @?= [] queryOptsFromOpts nulldate defreportopts @?= []
@ -586,4 +586,3 @@ tests_ReportOptions = tests "ReportOptions" [
queryOptsFromOpts nulldate defreportopts{period_=PeriodFrom (fromGregorian 2012 01 01) queryOptsFromOpts nulldate defreportopts{period_=PeriodFrom (fromGregorian 2012 01 01)
,query_="date:'to 2013'"} @?= [] ,query_="date:'to 2013'"} @?= []
] ]

247
hledger-lib/Hledger/Utils/Regex.hs
View File

@ -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: Easy regular expression helpers, currently based on regex-tdfa. These should:
@ -42,48 +46,120 @@ Current limitations:
-} -}
module Hledger.Utils.Regex ( module Hledger.Utils.Regex (
-- * Regexp type and constructors
Regexp(reString)
,toRegex_
,toRegexCI_
,toRegex'
,toRegexCI'
-- * type aliases -- * type aliases
Regexp
,Replacement ,Replacement
,RegexError ,RegexError
-- * partial regex operations (may call error) -- * partial regex operations (may call error)
,regexMatches -- ,regexMatches
,regexMatchesCI -- ,regexMatchesCI
,regexReplace -- ,regexReplaceCI
,regexReplaceCI -- ,regexReplaceCIMemo
,regexReplaceMemo -- ,regexReplaceByCI
,regexReplaceCIMemo
,regexReplaceBy
,regexReplaceByCI
-- * total regex operations -- * total regex operations
,regexMatches_ ,match
,regexMatchesCI_ ,regexReplace
,regexReplace_
,regexReplaceCI_
,regexReplaceMemo_ ,regexReplaceMemo_
,regexReplaceCIMemo_ -- ,replaceAllBy
,regexReplaceBy_ -- ,regexMatches_
,regexReplaceByCI_ -- ,regexMatchesCI_
,toRegex_ -- ,regexReplace_
-- ,regexReplaceCI_
-- ,regexReplaceMemo_
-- ,regexReplaceCIMemo_
,replaceAllBy
) )
where where
import Control.Arrow (first)
import Control.Monad (foldM) import Control.Monad (foldM)
import Data.Array import Data.Aeson (ToJSON(..), Value(String))
import Data.Char import Data.Array ((!), elems, indices)
import Data.Char (isDigit)
import Data.Data (Data(..), mkNoRepType)
import Data.List (foldl') import Data.List (foldl')
import Data.Maybe (fromMaybe)
import Data.MemoUgly (memo) import Data.MemoUgly (memo)
import qualified Data.Text as T
import Text.Regex.TDFA ( import Text.Regex.TDFA (
Regex, CompOption(..), ExecOption(..), defaultCompOpt, defaultExecOpt, Regex, CompOption(..), defaultCompOpt, defaultExecOpt,
makeRegexOptsM, AllMatches(getAllMatches), match, (=~), MatchText makeRegexOptsM, AllMatches(getAllMatches), match, MatchText,
RegexLike(..), RegexMaker(..), RegexOptions(..), RegexContext(..)
) )
import Hledger.Utils.UTF8IOCompat (error') import Hledger.Utils.UTF8IOCompat (error')
-- | Regular expression. Extended regular expression-ish syntax ? But does not support eg (?i) syntax. -- | 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). -- | A replacement pattern. May include numeric backreferences (\N).
type Replacement = String type Replacement = String
@ -91,61 +167,10 @@ type Replacement = String
-- | An regular expression compilation/processing error message. -- | An regular expression compilation/processing error message.
type RegexError = String 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 -- helpers
-- | Convert our string-based Regexp to a real Regex. regexReplace :: Regexp -> Replacement -> String -> String
-- Or if it's not well formed, call error with a "malformed regexp" message. regexReplace re repl s = foldl (replaceMatch repl) s (reverse $ match (reCompiled re) s :: [MatchText String])
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])
where where
replaceMatch :: Replacement -> String -> MatchText String -> String replaceMatch :: Replacement -> String -> MatchText String -> String
replaceMatch replpat s matchgroups = pre ++ repl ++ post 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 ((_,(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 (pre, post') = splitAt off s
post = drop len post' post = drop len post'
repl = replaceAllBy (toRegex "\\\\[0-9]+") (lookupMatchGroup matchgroups) replpat repl = replaceAllBy backrefRegex (lookupMatchGroup matchgroups) replpat
where where
lookupMatchGroup :: MatchText String -> String -> String lookupMatchGroup :: MatchText String -> String -> String
lookupMatchGroup grps ('\\':s@(_:_)) | all isDigit s = lookupMatchGroup grps ('\\':s@(_:_)) | all isDigit s =
@ -161,68 +186,22 @@ replaceRegex re repl s = foldl (replaceMatch repl) s (reverse $ match re s :: [M
-- PARTIAL: -- PARTIAL:
_ -> error' $ "no match group exists for backreference \"\\"++s++"\"" _ -> error' $ "no match group exists for backreference \"\\"++s++"\""
lookupMatchGroup _ s = error' $ "lookupMatchGroup called on non-numeric-backreference \""++s++"\", shouldn't happen" 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 -- 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 -- | A memoising version of regexReplace_. Caches the result for each
-- search pattern, replacement pattern, target string tuple. -- search pattern, replacement pattern, target string tuple.
regexReplaceMemo_ :: Regexp -> Replacement -> String -> Either RegexError String regexReplaceMemo_ :: Regexp -> Replacement -> String -> Either RegexError String
regexReplaceMemo_ re repl = memo (regexReplace_ re repl) regexReplaceMemo_ re repl = memo (replaceRegexUnmemo_ 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
-- helpers: -- 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 -- Replace this regular expression with this replacement pattern in this
-- string, or return an error message. -- string, or return an error message.
replaceRegex_ :: Regex -> Replacement -> String -> Either RegexError String replaceRegexUnmemo_ :: Regexp -> Replacement -> String -> Either RegexError String
replaceRegex_ re repl s = foldM (replaceMatch_ repl) s (reverse $ match re s :: [MatchText String]) replaceRegexUnmemo_ re repl s = foldM (replaceMatch_ repl) s (reverse $ match (reCompiled re) s :: [MatchText String])
where where
-- Replace one match within the string with the replacement text -- Replace one match within the string with the replacement text
-- appropriate for this match. Or return an error message. -- 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 -- The replacement text: the replacement pattern with all
-- numeric backreferences replaced by the appropriate groups -- numeric backreferences replaced by the appropriate groups
-- from this match. Or an error message. -- 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 where
-- Given some match groups and a numeric backreference, -- Given some match groups and a numeric backreference,
-- return the referenced group text, or an error message. -- 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) case read s of n | n `elem` indices grps -> Right $ fst (grps ! n)
_ -> Left $ "no match group exists for backreference \"\\"++s++"\"" _ -> 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
-- helpers -- 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 -- Replace all occurrences of a regexp in a string, transforming each match
-- with the given pure function. -- with the given pure function.
replaceAllBy :: Regex -> (String -> String) -> String -> String replaceAllBy :: Regexp -> (String -> String) -> String -> String
replaceAllBy re transform s = prependdone rest replaceAllBy re transform s = prependdone rest
where where
(_, rest, prependdone) = foldl' go (0, s, id) matches (_, rest, prependdone) = foldl' go (0, s, id) matches
where 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 :: (Int,String,String->String) -> (Int,Int) -> (Int,String,String->String)
go (pos,todo,prepend) (off,len) = go (pos,todo,prepend) (off,len) =
let (prematch, matchandrest) = splitAt (off - pos) todo 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 -- 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 -- from the transform function short-circuits and is returned as the overall
-- result. -- 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 = replaceAllByM re transform s =
foldM go (0, s, id) matches >>= \(_, rest, prependdone) -> pure $ prependdone rest foldM go (0, s, id) matches >>= \(_, rest, prependdone) -> pure $ prependdone rest
where 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 :: (Int,String,String->String) -> (Int,Int) -> m (Int,String,String->String)
go (pos,todo,prepend) (off,len) = go (pos,todo,prepend) (off,len) =
let (prematch, matchandrest) = splitAt (off - pos) todo let (prematch, matchandrest) = splitAt (off - pos) todo

6
hledger-lib/Hledger/Utils/String.hs
View File

@ -134,10 +134,10 @@ whitespacechars = " \t\n\r"
redirectchars = "<>" redirectchars = "<>"
escapeDoubleQuotes :: String -> String escapeDoubleQuotes :: String -> String
escapeDoubleQuotes = regexReplace "\"" "\"" escapeDoubleQuotes = id -- regexReplace "\"" "\""
escapeQuotes :: String -> String escapeQuotes :: String -> String
escapeQuotes = regexReplace "([\"'])" "\\1" escapeQuotes = id -- regexReplace "([\"'])" "\\1"
-- | Quote-aware version of words - don't split on spaces which are inside quotes. -- | 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. -- 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 where s' = stripAnsi s
stripAnsi :: String -> String 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 -- | Get the designated render width of a character: 0 for a combining
-- character, 1 for a regular character, 2 for a wide character. -- character, 1 for a regular character, 2 for a wide character.

2
hledger-ui/Hledger/UI/AccountsScreen.hs
View File

@ -90,7 +90,7 @@ asInit d reset ui@UIState{
excludeforecastq Nothing = -- not:date:tomorrow- not:tag:generated-transaction excludeforecastq Nothing = -- not:date:tomorrow- not:tag:generated-transaction
And [ And [
Not (Date $ DateSpan (Just $ addDays 1 d) Nothing) Not (Date $ DateSpan (Just $ addDays 1 d) Nothing)
,Not (Tag "generated-transaction" Nothing) ,Not (Tag (toRegexCI' "generated-transaction") Nothing)
] ]
-- run the report -- run the report

2
hledger-ui/Hledger/UI/Main.hs
View File

@ -122,7 +122,7 @@ runBrickUi uopts@UIOpts{cliopts_=copts@CliOpts{inputopts_=_iopts,reportopts_=rop
where where
acct = headDef acct = headDef
(error' $ "--register "++apat++" did not match any account") -- PARTIAL: (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 -- Initialising the accounts screen is awkward, requiring
-- another temporary UIState value.. -- another temporary UIState value..
ascr' = aScreen $ ascr' = aScreen $

2
hledger-ui/Hledger/UI/RegisterScreen.hs
View File

@ -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 excludeforecastq Nothing = -- not:date:tomorrow- not:tag:generated-transaction
And [ And [
Not (Date $ DateSpan (Just $ addDays 1 d) Nothing) 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 (_label,items) = accountTransactionsReport ropts' j q thisacctq

2
hledger-web/Hledger/Web/Widget/AddForm.hs
View File

@ -115,7 +115,7 @@ addForm j today = identifyForm "add" $ \extra -> do
] ]
where where
-- avoid https://github.com/simonmichael/hledger/issues/236 -- avoid https://github.com/simonmichael/hledger/issues/236
escapeJSSpecialChars = regexReplaceCI "</script>" "<\\/script>" escapeJSSpecialChars = regexReplace (toRegexCI' "</script>") "<\\/script>"
validateTransaction :: validateTransaction ::
FormResult Day FormResult Day

2
hledger-web/Hledger/Web/Widget/Common.hs
View File

@ -72,7 +72,7 @@ writeJournalTextIfValidAndChanged f t = do
-- Ensure unix line endings, since both readJournal (cf -- Ensure unix line endings, since both readJournal (cf
-- formatdirectivep, #1194) writeFileWithBackupIfChanged require them. -- formatdirectivep, #1194) writeFileWithBackupIfChanged require them.
-- XXX klunky. Any equivalent of "hSetNewlineMode h universalNewlineMode" for form posts ? -- 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 liftIO (readJournal def (Just f) t') >>= \case
Left e -> return (Left e) Left e -> return (Left e)
Right _ -> do Right _ -> do

30
hledger/Hledger/Cli/Commands.hs
View File

@ -61,7 +61,7 @@ import System.Environment (withArgs)
import System.Console.CmdArgs.Explicit as C import System.Console.CmdArgs.Explicit as C
import Test.Tasty (defaultMain) import Test.Tasty (defaultMain)
import Hledger import Hledger
import Hledger.Cli.CliOptions import Hledger.Cli.CliOptions
import Hledger.Cli.Version import Hledger.Cli.Version
import Hledger.Cli.Commands.Accounts import Hledger.Cli.Commands.Accounts
@ -137,7 +137,7 @@ builtinCommands = [
-- | The commands list, showing command names, standard aliases, -- | The commands list, showing command names, standard aliases,
-- and short descriptions. This is modified at runtime, as follows: -- 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: -- Lines beginning with a space represent builtin commands, with format:
-- COMMAND (ALIASES) DESCRIPTION -- COMMAND (ALIASES) DESCRIPTION
@ -152,10 +152,10 @@ builtinCommands = [
-- --
-- TODO: generate more of this automatically. -- TODO: generate more of this automatically.
-- --
commandsList :: String commandsList :: String -> [String] -> [String]
commandsList = unlines [ commandsList progversion othercmds = [
"-------------------------------------------------------------------------------" "-------------------------------------------------------------------------------"
,"PROGVERSION" ,progversion
,"Usage: hledger COMMAND [OPTIONS] [-- ADDONCMDOPTIONS]" ,"Usage: hledger COMMAND [OPTIONS] [-- ADDONCMDOPTIONS]"
,"Commands (+ addons found in $PATH):" ,"Commands (+ addons found in $PATH):"
,"" ,""
@ -208,8 +208,10 @@ commandsList = unlines [
,"+api run http api server" ,"+api run http api server"
,"" ,""
,"Other:" ,"Other:"
,"OTHER" ] ++
,"Help:" othercmds
++
["Help:"
," (no arguments) show this commands list" ," (no arguments) show this commands list"
," -h show general flags" ," -h show general flags"
," COMMAND -h show flags & docs for COMMAND" ," 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 -- | Extract the command names from commandsList: the first word
-- of lines beginning with a space or + sign. -- of lines beginning with a space or + sign.
commandsFromCommandsList :: String -> [String] commandsFromCommandsList :: [String] -> [String]
commandsFromCommandsList s = 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 :: [String]
knownCommands = sort $ commandsFromCommandsList commandsList knownCommands = sort . commandsFromCommandsList $ commandsList prognameandversion []
-- | Print the commands list, modifying the template above based on -- | Print the commands list, modifying the template above based on
-- the currently available addons. Missing addons will be removed, and -- the currently available addons. Missing addons will be removed, and
-- extra addons will be added under Misc. -- extra addons will be added under Misc.
printCommandsList :: [String] -> IO () printCommandsList :: [String] -> IO ()
printCommandsList addonsFound = printCommandsList addonsFound =
putStr $ putStr . unlines . concatMap adjustline $
regexReplace "PROGVERSION" (prognameandversion) $ commandsList prognameandversion (map ('+':) unknownCommandsFound)
regexReplace "OTHER" (unlines $ (map ('+':) unknownCommandsFound)) $
unlines $ concatMap adjustline $ lines $
cmdlist
where where
cmdlist = commandsList
commandsFound = map (' ':) builtinCommandNames ++ map ('+':) addonsFound commandsFound = map (' ':) builtinCommandNames ++ map ('+':) addonsFound
unknownCommandsFound = addonsFound \\ knownCommands unknownCommandsFound = addonsFound \\ knownCommands

13
hledger/Hledger/Cli/Commands/Aregister.hs
View File

@ -24,7 +24,9 @@ import Data.Aeson (toJSON)
import Data.Aeson.Text (encodeToLazyText) import Data.Aeson.Text (encodeToLazyText)
import Data.List import Data.List
import Data.Maybe 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 as T
import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy as TL
import Data.Time (addDays) 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: when (null args') $ error' "aregister needs an account, please provide an account name or pattern" -- PARTIAL:
let let
(apat:queryargs) = args' (apat:queryargs) = args'
apatregex = toRegex' apat -- PARTIAL: do better
acct = headDef (error' $ show apat++" did not match any account") $ -- PARTIAL: 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 -- gather report options
inclusive = True -- tree_ ropts inclusive = True -- tree_ ropts
thisacctq = Acct $ (if inclusive then accountNameToAccountRegex else accountNameToAccountOnlyRegex) acct 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 excludeforecastq False = -- not:date:tomorrow- not:tag:generated-transaction
And [ And [
Not (Date $ DateSpan (Just $ addDays 1 d) Nothing) Not (Date $ DateSpan (Just $ addDays 1 d) Nothing)
,Not (Tag "generated-transaction" Nothing) ,Not (Tag (toRegex' "generated-transaction") Nothing)
] ]
-- run the report -- run the report
-- TODO: need to also pass the queries so we can choose which date to render - move them into 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 itemamt (_,_,_,_,a,_) = a
itembal (_,_,_,_,_,a) = a itembal (_,_,_,_,_,a) = a
-- show a title indicating which account was picked, which can be confusing otherwise -- 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 where
-- XXX temporary hack ? recover the account name from the query -- XXX temporary hack ? recover the account name from the query
macct = case filterQuery queryIsAcct thisacctq of 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 _ -> Nothing -- shouldn't happen
-- | Render one account register report line item as plain text. Layout is like so: -- | Render one account register report line item as plain text. Layout is like so:

4
hledger/Hledger/Cli/Commands/Files.hs
View File

@ -33,8 +33,8 @@ filesmode = hledgerCommandMode
files :: CliOpts -> Journal -> IO () files :: CliOpts -> Journal -> IO ()
files CliOpts{rawopts_=rawopts} j = do files CliOpts{rawopts_=rawopts} j = do
let args = listofstringopt "args" rawopts let args = listofstringopt "args" rawopts
regex = headMay args regex <- mapM (either fail pure . toRegex_) $ headMay args
files = maybe id (filter . regexMatches) regex let files = maybe id (filter . match) regex
$ map fst $ map fst
$ jfiles j $ jfiles j
mapM_ putStrLn files mapM_ putStrLn files

7
hledger/Hledger/Cli/Commands/Tags.hs
View File

@ -7,6 +7,7 @@ module Hledger.Cli.Commands.Tags (
) )
where where
import qualified Control.Monad.Fail as Fail
import Data.List.Extra (nubSort) import Data.List.Extra (nubSort)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.IO as T import qualified Data.Text.IO as T
@ -24,11 +25,13 @@ tagsmode = hledgerCommandMode
hiddenflags hiddenflags
([], Just $ argsFlag "[TAGREGEX [QUERY...]]") ([], Just $ argsFlag "[TAGREGEX [QUERY...]]")
tags :: CliOpts -> Journal -> IO ()
tags CliOpts{rawopts_=rawopts,reportopts_=ropts} j = do tags CliOpts{rawopts_=rawopts,reportopts_=ropts} j = do
d <- getCurrentDay d <- getCurrentDay
let let
args = listofstringopt "args" rawopts args = listofstringopt "args" rawopts
mtagpat = headMay args mtagpat <- mapM (either Fail.fail pure . toRegexCI_) $ headMay args
let
queryargs = drop 1 args queryargs = drop 1 args
values = boolopt "values" rawopts values = boolopt "values" rawopts
parsed = boolopt "parsed" rawopts parsed = boolopt "parsed" rawopts
@ -39,7 +42,7 @@ tags CliOpts{rawopts_=rawopts,reportopts_=ropts} j = do
(if parsed then id else nubSort) (if parsed then id else nubSort)
[ r [ r
| (t,v) <- concatMap transactionAllTags txns | (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 , let r = if values then v else t
, not (values && T.null v && not empty) , not (values && T.null v && not empty)
] ]

16
hledger/Hledger/Cli/Main.hs
View File

@ -82,14 +82,14 @@ mainmode addons = defMode {
[detailedversionflag] [detailedversionflag]
-- ++ inputflags -- included here so they'll not raise a confusing error if present with no COMMAND -- ++ inputflags -- included here so they'll not raise a confusing error if present with no COMMAND
} }
,modeHelpSuffix = map (regexReplace "PROGNAME" progname) [ ,modeHelpSuffix = "Examples:" :
"Examples:" map (progname ++) [
,"PROGNAME list commands" " list commands"
,"PROGNAME CMD [--] [OPTS] [ARGS] run a command (use -- with addon commands)" ," CMD [--] [OPTS] [ARGS] run a command (use -- with addon commands)"
,"PROGNAME-CMD [OPTS] [ARGS] or run addon commands directly" ,"-CMD [OPTS] [ARGS] or run addon commands directly"
,"PROGNAME -h show general usage" ," -h show general usage"
,"PROGNAME CMD -h show command usage" ," CMD -h show command usage"
,"PROGNAME help [MANUAL] show any of the hledger manuals in various formats" ," help [MANUAL] show any of the hledger manuals in various formats"
] ]
} }