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