2011-06-05 22:36:32 +04:00
{- |
2012-05-27 22:14:20 +04:00
A general query system for matching things ( accounts , postings ,
2017-07-27 14:59:55 +03:00
transactions .. ) by various criteria , and a SimpleTextParser for query expressions .
2011-06-05 22:36:32 +04:00
- }
2020-08-15 12:14:27 +03:00
{- # LANGUAGE FlexibleContexts # -}
{- # LANGUAGE OverloadedStrings # -}
{- # LANGUAGE ViewPatterns # -}
lib: textification begins! account names
The first of several conversions from String to (strict) Text, hopefully
reducing space and time usage.
This one shows a small improvement, with GHC 7.10.3 and text-1.2.2.1:
hledger -f data/100x100x10.journal stats
string: <<ghc: 39471064 bytes, 77 GCs, 198421/275048 avg/max bytes residency (3 samples), 2M in use, 0.000 INIT (0.001 elapsed), 0.015 MUT (0.020 elapsed), 0.010 GC (0.014 elapsed) :ghc>>
text: <<ghc: 39268024 bytes, 77 GCs, 197018/270840 avg/max bytes residency (3 samples), 2M in use, 0.000 INIT (0.002 elapsed), 0.016 MUT (0.022 elapsed), 0.009 GC (0.011 elapsed) :ghc>>
hledger -f data/1000x100x10.journal stats
string: <<ghc: 318555920 bytes, 617 GCs, 2178997/7134472 avg/max bytes residency (7 samples), 16M in use, 0.000 INIT (0.001 elapsed), 0.129 MUT (0.136 elapsed), 0.067 GC (0.077 elapsed) :ghc>>
text: <<ghc: 314248496 bytes, 612 GCs, 2074045/6617960 avg/max bytes residency (7 samples), 16M in use, 0.000 INIT (0.003 elapsed), 0.137 MUT (0.145 elapsed), 0.067 GC (0.079 elapsed) :ghc>>
hledger -f data/10000x100x10.journal stats
string: <<ghc: 3114763608 bytes, 6026 GCs, 18858950/75552024 avg/max bytes residency (11 samples), 201M in use, 0.000 INIT (0.000 elapsed), 1.331 MUT (1.372 elapsed), 0.699 GC (0.812 elapsed) :ghc>>
text: <<ghc: 3071468920 bytes, 5968 GCs, 14120344/62951360 avg/max bytes residency (9 samples), 124M in use, 0.000 INIT (0.003 elapsed), 1.272 MUT (1.349 elapsed), 0.513 GC (0.578 elapsed) :ghc>>
hledger -f data/100000x100x10.journal stats
string: <<ghc: 31186579432 bytes, 60278 GCs, 135332581/740228992 avg/max bytes residency (13 samples), 1697M in use, 0.000 INIT (0.008 elapsed), 14.677 MUT (15.508 elapsed), 7.081 GC (8.074 elapsed) :ghc>>
text: <<ghc: 30753427672 bytes, 59763 GCs, 117595958/666457240 avg/max bytes residency (14 samples), 1588M in use, 0.000 INIT (0.008 elapsed), 13.713 MUT (13.966 elapsed), 6.220 GC (7.108 elapsed) :ghc>>
2016-05-24 04:16:21 +03:00
2012-05-16 11:57:10 +04:00
module Hledger.Query (
2012-05-16 11:50:22 +04:00
-- * Query and QueryOpt
2012-05-16 11:12:49 +04:00
Query ( .. ) ,
2012-05-16 11:50:22 +04:00
QueryOpt ( .. ) ,
2020-10-09 02:10:15 +03:00
OrdPlus ( .. ) ,
2020-09-01 04:36:34 +03:00
payeeTag ,
noteTag ,
generatedTransactionTag ,
2012-05-16 12:28:02 +04:00
-- * parsing
parseQuery ,
2020-11-04 14:19:26 +03:00
parseQueryList ,
2021-08-04 07:29:58 +03:00
parseQueryTerm ,
2022-01-30 15:45:19 +03:00
parseAccountType ,
2022-04-14 22:55:07 +03:00
-- * modifying
2012-05-17 20:02:22 +04:00
simplifyQuery ,
2012-05-27 22:14:20 +04:00
filterQuery ,
2021-12-10 01:57:26 +03:00
filterQueryOrNotQuery ,
2022-04-14 22:55:07 +03:00
matchesQuery ,
-- * predicates
2012-05-16 11:37:24 +04:00
queryIsNull ,
2012-05-27 22:14:20 +04:00
queryIsDate ,
2014-12-25 03:11:30 +03:00
queryIsDate2 ,
queryIsDateOrDate2 ,
2016-06-04 03:51:10 +03:00
queryIsStatus ,
2022-04-14 23:46:57 +03:00
queryIsCode ,
queryIsDesc ,
2022-01-29 08:56:49 +03:00
queryIsTag ,
2022-04-14 23:46:57 +03:00
queryIsAcct ,
queryIsType ,
queryIsDepth ,
queryIsReal ,
queryIsAmt ,
queryIsSym ,
queryIsStartDateOnly ,
queryIsTransactionRelated ,
2022-04-14 22:55:07 +03:00
-- * accessors
2012-05-27 22:14:20 +04:00
queryStartDate ,
2014-07-15 18:01:01 +04:00
queryEndDate ,
2012-05-27 22:14:20 +04:00
queryDateSpan ,
2014-12-25 03:11:30 +03:00
queryDateSpan' ,
2012-05-27 22:14:20 +04:00
queryDepth ,
2012-05-16 10:43:13 +04:00
inAccount ,
2012-05-16 11:37:24 +04:00
inAccountQuery ,
2022-04-14 22:55:07 +03:00
-- * matching things with queries
2012-05-27 22:14:20 +04:00
matchesTransaction ,
2022-01-30 15:45:19 +03:00
matchesTransactionExtra ,
2021-01-18 03:17:16 +03:00
matchesDescription ,
matchesPayeeWIP ,
2014-02-28 05:47:47 +04:00
matchesPosting ,
2022-01-30 15:45:19 +03:00
matchesPostingExtra ,
2014-02-28 05:47:47 +04:00
matchesAccount ,
2022-01-30 15:45:19 +03:00
matchesAccountExtra ,
2014-04-06 06:33:44 +04:00
matchesMixedAmount ,
2014-02-28 05:47:47 +04:00
matchesAmount ,
2018-07-15 10:37:13 +03:00
matchesCommodity ,
2020-08-07 17:53:00 +03:00
matchesTags ,
2019-06-04 03:26:27 +03:00
matchesPriceDirective ,
2014-04-15 22:45:30 +04:00
words'' ,
2022-08-23 13:58:31 +03:00
queryprefixes ,
2012-05-16 11:50:22 +04:00
-- * tests
2018-09-06 23:08:26 +03:00
tests_Query
2012-05-16 10:43:13 +04:00
)
2011-06-05 22:36:32 +04:00
where
2018-09-04 19:59:48 +03:00
2020-09-01 04:36:34 +03:00
import Control.Applicative ( ( <|> ) , many , optional )
2020-09-02 14:00:45 +03:00
import Data.Default ( Default ( .. ) )
2021-08-16 09:46:40 +03:00
import Data.Either ( fromLeft , partitionEithers )
2022-01-30 22:32:52 +03:00
import Data.List ( partition , intercalate )
2020-08-31 07:56:38 +03:00
import Data.Maybe ( fromMaybe , isJust , mapMaybe )
2020-12-27 02:52:39 +03:00
import Data.Text ( Text )
lib: textification begins! account names
The first of several conversions from String to (strict) Text, hopefully
reducing space and time usage.
This one shows a small improvement, with GHC 7.10.3 and text-1.2.2.1:
hledger -f data/100x100x10.journal stats
string: <<ghc: 39471064 bytes, 77 GCs, 198421/275048 avg/max bytes residency (3 samples), 2M in use, 0.000 INIT (0.001 elapsed), 0.015 MUT (0.020 elapsed), 0.010 GC (0.014 elapsed) :ghc>>
text: <<ghc: 39268024 bytes, 77 GCs, 197018/270840 avg/max bytes residency (3 samples), 2M in use, 0.000 INIT (0.002 elapsed), 0.016 MUT (0.022 elapsed), 0.009 GC (0.011 elapsed) :ghc>>
hledger -f data/1000x100x10.journal stats
string: <<ghc: 318555920 bytes, 617 GCs, 2178997/7134472 avg/max bytes residency (7 samples), 16M in use, 0.000 INIT (0.001 elapsed), 0.129 MUT (0.136 elapsed), 0.067 GC (0.077 elapsed) :ghc>>
text: <<ghc: 314248496 bytes, 612 GCs, 2074045/6617960 avg/max bytes residency (7 samples), 16M in use, 0.000 INIT (0.003 elapsed), 0.137 MUT (0.145 elapsed), 0.067 GC (0.079 elapsed) :ghc>>
hledger -f data/10000x100x10.journal stats
string: <<ghc: 3114763608 bytes, 6026 GCs, 18858950/75552024 avg/max bytes residency (11 samples), 201M in use, 0.000 INIT (0.000 elapsed), 1.331 MUT (1.372 elapsed), 0.699 GC (0.812 elapsed) :ghc>>
text: <<ghc: 3071468920 bytes, 5968 GCs, 14120344/62951360 avg/max bytes residency (9 samples), 124M in use, 0.000 INIT (0.003 elapsed), 1.272 MUT (1.349 elapsed), 0.513 GC (0.578 elapsed) :ghc>>
hledger -f data/100000x100x10.journal stats
string: <<ghc: 31186579432 bytes, 60278 GCs, 135332581/740228992 avg/max bytes residency (13 samples), 1697M in use, 0.000 INIT (0.008 elapsed), 14.677 MUT (15.508 elapsed), 7.081 GC (8.074 elapsed) :ghc>>
text: <<ghc: 30753427672 bytes, 59763 GCs, 117595958/666457240 avg/max bytes residency (14 samples), 1588M in use, 0.000 INIT (0.008 elapsed), 13.713 MUT (13.966 elapsed), 6.220 GC (7.108 elapsed) :ghc>>
2016-05-24 04:16:21 +03:00
import qualified Data.Text as T
2020-08-31 07:56:38 +03:00
import Data.Time.Calendar ( Day , fromGregorian )
2020-08-05 03:39:48 +03:00
import Safe ( readDef , readMay , maximumByMay , maximumMay , minimumMay )
2020-08-15 12:14:27 +03:00
import Text.Megaparsec ( between , noneOf , sepBy )
2020-08-31 07:56:38 +03:00
import Text.Megaparsec.Char ( char , string )
2011-06-05 22:36:32 +04:00
2018-09-04 23:52:36 +03:00
import Hledger.Utils hiding ( words' )
2011-06-05 22:36:32 +04:00
import Hledger.Data.Types
2011-06-14 18:29:31 +04:00
import Hledger.Data.AccountName
lib: Change internal representation of MixedAmount to use a strict Map
instead of a list of Amounts. No longer export Mixed constructor, to
keep API clean (if you really need it, you can import it directly from
Hledger.Data.Types). We also ensure the JSON representation of
MixedAmount doesn't change: it is stored as a normalised list of
Amounts.
This commit improves performance. Here are some indicative results.
hledger reg -f examples/10000x1000x10.journal
- Maximum residency decreases from 65MB to 60MB (8% decrease)
- Total memory in use decreases from 178MiB to 157MiB (12% decrease)
hledger reg -f examples/10000x10000x10.journal
- Maximum residency decreases from 69MB to 60MB (13% decrease)
- Total memory in use decreases from 198MiB to 153MiB (23% decrease)
hledger bal -f examples/10000x1000x10.journal
- Total heap usage decreases from 6.4GB to 6.0GB (6% decrease)
- Total memory in use decreases from 178MiB to 153MiB (14% decrease)
hledger bal -f examples/10000x10000x10.journal
- Total heap usage decreases from 7.3GB to 6.9GB (5% decrease)
- Total memory in use decreases from 196MiB to 185MiB (5% decrease)
hledger bal -M -f examples/10000x1000x10.journal
- Total heap usage decreases from 16.8GB to 10.6GB (47% decrease)
- Total time decreases from 14.3s to 12.0s (16% decrease)
hledger bal -M -f examples/10000x10000x10.journal
- Total heap usage decreases from 108GB to 48GB (56% decrease)
- Total time decreases from 62s to 41s (33% decrease)
If you never directly use the constructor Mixed or pattern match against
it then you don't need to make any changes. If you do, then do the
following:
- If you really care about the individual Amounts and never normalise
your MixedAmount (for example, just storing `Mixed amts` and then
extracting `amts` as a pattern match, then use should switch to using
[Amount]. This should just involve removing the `Mixed` constructor.
- If you ever call `mixed`, `normaliseMixedAmount`, or do any sort of
amount arithmetic (+), (-), then you should replace the constructor
`Mixed` with the function `mixed`. To extract the list of Amounts, use
the function `amounts`.
- If you ever call `normaliseMixedAmountSquashPricesForDisplay`, you can
replace that with `mixedAmountStripPrices`. (N.B. this does something
slightly different from `normaliseMixedAmountSquashPricesForDisplay`,
but I don't think there's any use case for squashing prices and then
keeping the first of the squashed prices around. If you disagree let
me know.)
- Any remaining calls to `normaliseMixedAmount` can be removed, as that
is now the identity function.
2021-01-29 08:07:11 +03:00
import Hledger.Data.Amount ( amountsRaw , mixedAmount , nullamt , usd )
2011-06-05 22:36:32 +04:00
import Hledger.Data.Dates
2011-06-29 03:18:36 +04:00
import Hledger.Data.Posting
import Hledger.Data.Transaction
2011-06-05 22:36:32 +04:00
2012-05-16 11:50:22 +04:00
2012-05-16 11:37:24 +04:00
-- | A query is a composition of search criteria, which can be used to
-- match postings, transactions, accounts and more.
2022-04-15 00:33:19 +03:00
data Query =
-- compound queries
Not Query -- ^ negate this match
| And [ Query ] -- ^ match if all of these match
| Or [ Query ] -- ^ match if any of these match
-- no-op queries
| Any -- ^ always match
| None -- ^ never match
-- data queries (in "standard" order, roughly as they appear in a transaction)
| Date DateSpan -- ^ match primary dates in this date span
| Date2 DateSpan -- ^ match secondary dates in this date span
| StatusQ Status -- ^ match this txn/posting status
| Code Regexp -- ^ match txn codes infix-matched by this regexp
| Desc Regexp -- ^ match txn descriptions infix-matched by this regexp
| Tag Regexp ( Maybe Regexp ) -- ^ match if a tag's name, and optionally its value, is infix-matched by the respective regexps
| Acct Regexp -- ^ match account names infix-matched by this regexp
| Type [ AccountType ] -- ^ match accounts whose type is one of these (or with no types, any account)
| Depth Int -- ^ match if account depth is less than or equal to this value (or, sometimes used as a display option)
| Real Bool -- ^ match postings with this "realness" value
| Amt OrdPlus Quantity -- ^ match if the amount's numeric quantity is less than/greater than/equal to/unsignedly equal to some value
| Sym Regexp -- ^ match if the commodity symbol is fully-matched by this regexp
deriving ( Eq , Show )
2013-09-23 22:50:20 +04:00
2020-09-02 14:00:45 +03:00
instance Default Query where def = Any
2020-08-15 12:14:27 +03:00
-- | Construct a payee tag
2020-12-27 02:52:39 +03:00
payeeTag :: Maybe Text -> Either RegexError Query
2020-09-01 04:36:34 +03:00
payeeTag = fmap ( Tag ( toRegexCI' " payee " ) ) . maybe ( pure Nothing ) ( fmap Just . toRegexCI )
2020-08-15 12:14:27 +03:00
-- | Construct a note tag
2020-12-27 02:52:39 +03:00
noteTag :: Maybe Text -> Either RegexError Query
2020-09-01 04:36:34 +03:00
noteTag = fmap ( Tag ( toRegexCI' " note " ) ) . maybe ( pure Nothing ) ( fmap Just . toRegexCI )
-- | Construct a generated-transaction tag
generatedTransactionTag :: Query
generatedTransactionTag = Tag ( toRegexCI' " generated-transaction " ) Nothing
2020-08-15 12:14:27 +03:00
2018-09-04 17:29:48 +03:00
-- | A more expressive Ord, used for amt: queries. The Abs* variants
-- compare with the absolute value of a number, ignoring sign.
data OrdPlus = Lt | LtEq | Gt | GtEq | Eq | AbsLt | AbsLtEq | AbsGt | AbsGtEq | AbsEq
2020-08-31 07:56:38 +03:00
deriving ( Show , Eq )
2018-09-04 17:29:48 +03:00
2011-06-13 23:46:35 +04:00
-- | A query option changes a query's/report's behaviour and output in some way.
2011-07-01 04:32:09 +04:00
data QueryOpt = QueryOptInAcctOnly AccountName -- ^ show an account register focussed on this account
| QueryOptInAcct AccountName -- ^ as above but include sub-accounts in the account register
2011-06-13 23:46:35 +04:00
-- | QueryOptCostBasis -- ^ show amounts converted to cost where possible
2012-12-06 08:43:41 +04:00
-- | QueryOptDate2 -- ^ show secondary dates instead of primary dates
2020-08-31 07:56:38 +03:00
deriving ( Show , Eq )
2011-06-13 23:46:35 +04:00
2012-05-16 12:28:02 +04:00
-- parsing
2012-05-16 11:50:22 +04:00
2012-05-16 11:37:24 +04:00
-- -- | A query restricting the account(s) to be shown in the sidebar, if any.
2011-07-01 04:32:09 +04:00
-- -- Just looks at the first query option.
2012-05-16 11:12:49 +04:00
-- showAccountMatcher :: [QueryOpt] -> Maybe Query
-- showAccountMatcher (QueryOptInAcctSubsOnly a:_) = Just $ Acct True $ accountNameToAccountRegex a
2011-07-01 04:32:09 +04:00
-- showAccountMatcher _ = Nothing
2011-06-13 23:46:35 +04:00
2012-05-27 22:14:20 +04:00
2020-11-04 14:19:26 +03:00
-- | A version of parseQueryList which acts on a single Text of
-- space-separated terms.
--
-- The usual shell quoting rules are assumed. When a pattern contains
-- whitespace, it (or the whole term including prefix) should be enclosed
-- in single or double quotes.
--
-- >>> parseQuery nulldate "expenses:dining out"
-- Right (Or [Acct (RegexpCI "expenses:dining"),Acct (RegexpCI "out")],[])
--
-- >>> parseQuery nulldate "\"expenses:dining out\""
-- Right (Acct (RegexpCI "expenses:dining out"),[])
parseQuery :: Day -> T . Text -> Either String ( Query , [ QueryOpt ] )
2022-08-23 13:58:31 +03:00
parseQuery d = parseQueryList d . words'' queryprefixes
2020-11-04 14:19:26 +03:00
-- | Convert a list of query expression containing to a query and zero
-- or more query options; or return an error message if query parsing fails.
2020-08-05 03:39:48 +03:00
--
-- A query term is either:
2011-06-13 02:35:54 +04:00
--
2012-05-27 22:14:20 +04:00
-- 1. a search pattern, which matches on one or more fields, eg:
--
-- acct:REGEXP - match the account name with a regular expression
-- desc:REGEXP - match the transaction description
-- date:PERIODEXP - match the date with a period expression
--
-- The prefix indicates the field to match, or if there is no prefix
-- account name is assumed.
--
-- 2. a query option, which modifies the reporting behaviour in some
-- way. There is currently one of these, which may appear only once:
2011-06-13 02:35:54 +04:00
--
2012-05-27 22:14:20 +04:00
-- inacct:FULLACCTNAME
2011-06-13 02:35:54 +04:00
--
2012-05-27 22:14:20 +04:00
-- Period expressions may contain relative dates, so a reference date is
-- required to fully parse these.
--
-- Multiple terms are combined as follows:
-- 1. multiple account patterns are OR'd together
-- 2. multiple description patterns are OR'd together
2017-06-10 23:31:43 +03:00
-- 3. multiple status patterns are OR'd together
-- 4. then all terms are AND'd together
2020-11-04 14:19:26 +03:00
parseQueryList :: Day -> [ T . Text ] -> Either String ( Query , [ QueryOpt ] )
parseQueryList d termstrs = do
2021-08-23 10:14:14 +03:00
eterms <- mapM ( parseQueryTerm d ) termstrs
2020-08-05 23:41:13 +03:00
let ( pats , opts ) = partitionEithers eterms
( descpats , pats' ) = partition queryIsDesc pats
( acctpats , pats'' ) = partition queryIsAcct pats'
( statuspats , otherpats ) = partition queryIsStatus pats''
q = simplifyQuery $ And $ [ Or acctpats , Or descpats , Or statuspats ] ++ otherpats
Right ( q , opts )
2011-06-13 23:46:35 +04:00
2012-05-29 21:02:18 +04:00
-- XXX
2011-06-14 18:27:48 +04:00
-- | Quote-and-prefix-aware version of words - don't split on spaces which
-- are inside quotes, including quotes which may have one of the specified
-- prefixes in front, and maybe an additional not: prefix in front of that.
2016-07-29 18:57:10 +03:00
words'' :: [ T . Text ] -> T . Text -> [ T . Text ]
2011-06-14 18:27:48 +04:00
words'' prefixes = fromparse . parsewith maybeprefixedquotedphrases -- XXX
where
2017-07-27 14:59:55 +03:00
maybeprefixedquotedphrases :: SimpleTextParser [ T . Text ]
2021-08-16 09:38:27 +03:00
maybeprefixedquotedphrases = choice' [ prefixedQuotedPattern , singleQuotedPattern , doubleQuotedPattern , patterns ] ` sepBy ` skipNonNewlineSpaces1
2017-07-27 14:59:55 +03:00
prefixedQuotedPattern :: SimpleTextParser T . Text
2011-06-14 18:27:48 +04:00
prefixedQuotedPattern = do
2018-05-22 01:47:56 +03:00
not' <- fromMaybe " " ` fmap ` ( optional $ string " not: " )
2017-07-27 14:59:55 +03:00
let allowednexts | T . null not' = prefixes
| otherwise = prefixes ++ [ " " ]
2018-05-22 01:47:56 +03:00
next <- choice' $ map string allowednexts
2016-07-29 18:57:10 +03:00
let prefix :: T . Text
2017-07-27 14:59:55 +03:00
prefix = not' <> next
2014-04-15 22:45:30 +04:00
p <- singleQuotedPattern <|> doubleQuotedPattern
2016-07-29 18:57:10 +03:00
return $ prefix <> stripquotes p
2017-07-27 14:59:55 +03:00
singleQuotedPattern :: SimpleTextParser T . Text
2021-08-16 09:46:40 +03:00
singleQuotedPattern = stripquotes . T . pack <$> between ( char '\ ' ' ) ( char '\ ' ' ) ( many $ noneOf ( " ' " :: [ Char ] ) )
2017-07-27 14:59:55 +03:00
doubleQuotedPattern :: SimpleTextParser T . Text
2021-08-16 09:46:40 +03:00
doubleQuotedPattern = stripquotes . T . pack <$> between ( char '"' ) ( char '"' ) ( many $ noneOf ( " \ " " :: [ Char ] ) )
2021-08-16 09:38:27 +03:00
patterns :: SimpleTextParser T . Text
2021-08-16 09:46:40 +03:00
patterns = T . pack <$> many ( noneOf ( " \ n \ r " :: [ Char ] ) )
2011-06-14 18:27:48 +04:00
2012-05-29 21:02:18 +04:00
-- XXX
-- keep synced with patterns below, excluding "not"
2022-08-23 13:58:31 +03:00
queryprefixes :: [ T . Text ]
queryprefixes = map ( <> " : " ) [
2012-05-29 21:02:18 +04:00
" inacctonly "
, " inacct "
2013-09-10 02:04:43 +04:00
, " amt "
2013-03-22 21:59:16 +04:00
, " code "
2012-05-29 21:02:18 +04:00
, " desc "
2017-08-31 00:21:01 +03:00
, " payee "
, " note "
2012-05-29 21:02:18 +04:00
, " acct "
, " date "
2014-12-16 22:06:21 +03:00
, " date2 "
2012-05-29 21:02:18 +04:00
, " status "
2014-03-16 20:43:15 +04:00
, " cur "
2012-05-29 21:02:18 +04:00
, " real "
, " empty "
, " depth "
, " tag "
2022-01-30 15:45:19 +03:00
, " type "
2012-05-29 21:02:18 +04:00
]
2016-07-29 18:57:10 +03:00
defaultprefix :: T . Text
2012-05-29 21:02:18 +04:00
defaultprefix = " acct "
2011-06-14 18:27:48 +04:00
-- -- | Parse the query string as a boolean tree of match patterns.
2012-05-16 11:12:49 +04:00
-- parseQueryTerm :: String -> Query
-- parseQueryTerm s = either (const (Any)) id $ runParser query () "" $ lexmatcher s
2011-06-14 18:27:48 +04:00
-- lexmatcher :: String -> [String]
-- lexmatcher s = words' s
2012-05-16 11:12:49 +04:00
-- query :: GenParser String () Query
2012-05-16 11:37:24 +04:00
-- query = undefined
2011-06-14 18:27:48 +04:00
2014-08-08 04:26:08 +04:00
-- | Parse a single query term as either a query or a query option,
2020-08-05 23:41:13 +03:00
-- or return an error message if parsing fails.
parseQueryTerm :: Day -> T . Text -> Either String ( Either Query QueryOpt )
parseQueryTerm _ ( T . stripPrefix " inacctonly: " -> Just s ) = Right $ Right $ QueryOptInAcctOnly s
parseQueryTerm _ ( T . stripPrefix " inacct: " -> Just s ) = Right $ Right $ QueryOptInAcct s
2016-07-29 18:57:10 +03:00
parseQueryTerm d ( T . stripPrefix " not: " -> Just s ) =
case parseQueryTerm d s of
2020-08-05 23:41:13 +03:00
Right ( Left m ) -> Right $ Left $ Not m
Right ( Right _ ) -> Right $ Left Any -- not:somequeryoption will be ignored
Left err -> Left err
2020-12-27 02:52:39 +03:00
parseQueryTerm _ ( T . stripPrefix " code: " -> Just s ) = Left . Code <$> toRegexCI s
parseQueryTerm _ ( T . stripPrefix " desc: " -> Just s ) = Left . Desc <$> toRegexCI s
parseQueryTerm _ ( T . stripPrefix " payee: " -> Just s ) = Left <$> payeeTag ( Just s )
parseQueryTerm _ ( T . stripPrefix " note: " -> Just s ) = Left <$> noteTag ( Just s )
parseQueryTerm _ ( T . stripPrefix " acct: " -> Just s ) = Left . Acct <$> toRegexCI s
2016-07-29 18:57:10 +03:00
parseQueryTerm d ( T . stripPrefix " date2: " -> Just s ) =
2020-08-05 23:41:13 +03:00
case parsePeriodExpr d s of Left e -> Left $ " \ " date2: " ++ T . unpack s ++ " \ " gave a " ++ showDateParseError e
2022-08-23 13:58:31 +03:00
Right ( _ , spn ) -> Right $ Left $ Date2 spn
2016-07-29 18:57:10 +03:00
parseQueryTerm d ( T . stripPrefix " date: " -> Just s ) =
2020-08-05 23:41:13 +03:00
case parsePeriodExpr d s of Left e -> Left $ " \ " date: " ++ T . unpack s ++ " \ " gave a " ++ showDateParseError e
2022-08-23 13:58:31 +03:00
Right ( _ , spn ) -> Right $ Left $ Date spn
2016-07-29 18:57:10 +03:00
parseQueryTerm _ ( T . stripPrefix " status: " -> Just s ) =
2020-08-05 23:41:13 +03:00
case parseStatus s of Left e -> Left $ " \ " status: " ++ T . unpack s ++ " \ " gave a parse error: " ++ e
Right st -> Right $ Left $ StatusQ st
parseQueryTerm _ ( T . stripPrefix " real: " -> Just s ) = Right $ Left $ Real $ parseBool s || T . null s
2020-08-06 02:05:56 +03:00
parseQueryTerm _ ( T . stripPrefix " amt: " -> Just s ) = Right $ Left $ Amt ord q where ( ord , q ) = either error id $ parseAmountQueryTerm s -- PARTIAL:
2016-07-29 18:57:10 +03:00
parseQueryTerm _ ( T . stripPrefix " depth: " -> Just s )
2020-08-05 23:41:13 +03:00
| n >= 0 = Right $ Left $ Depth n
| otherwise = Left " depth: should have a positive number "
2016-07-29 18:57:10 +03:00
where n = readDef 0 ( T . unpack s )
2015-08-28 19:57:30 +03:00
2020-12-27 02:52:39 +03:00
parseQueryTerm _ ( T . stripPrefix " cur: " -> Just s ) = Left . Sym <$> toRegexCI ( " ^ " <> s <> " $ " ) -- support cur: as an alias
2020-08-15 12:14:27 +03:00
parseQueryTerm _ ( T . stripPrefix " tag: " -> Just s ) = Left <$> parseTag s
2022-01-30 22:32:52 +03:00
parseQueryTerm _ ( T . stripPrefix " type: " -> Just s ) = Left <$> parseTypeCodes s
2020-08-05 23:41:13 +03:00
parseQueryTerm _ " " = Right $ Left $ Any
2016-07-29 18:57:10 +03:00
parseQueryTerm d s = parseQueryTerm d $ defaultprefix <> " : " <> s
2011-06-13 23:46:35 +04:00
2020-08-05 03:39:48 +03:00
-- | Parse the argument of an amt query term ([OP][SIGN]NUM), to an
-- OrdPlus and a Quantity, or if parsing fails, an error message. OP
-- can be <=, <, >=, >, or = . NUM can be a simple integer or decimal.
-- If a decimal, the decimal mark must be period, and it must have
-- digits preceding it. Digit group marks are not allowed.
parseAmountQueryTerm :: T . Text -> Either String ( OrdPlus , Quantity )
parseAmountQueryTerm amtarg =
case amtarg of
-- number has a + sign, do a signed comparison
( parse " <=+ " -> Just q ) -> Right ( LtEq , q )
( parse " <+ " -> Just q ) -> Right ( Lt , q )
( parse " >=+ " -> Just q ) -> Right ( GtEq , q )
( parse " >+ " -> Just q ) -> Right ( Gt , q )
( parse " =+ " -> Just q ) -> Right ( Eq , q )
( parse " + " -> Just q ) -> Right ( Eq , q )
-- number has a - sign, do a signed comparison
( parse " <- " -> Just q ) -> Right ( Lt , - q )
( parse " <=- " -> Just q ) -> Right ( LtEq , - q )
( parse " >- " -> Just q ) -> Right ( Gt , - q )
( parse " >=- " -> Just q ) -> Right ( GtEq , - q )
( parse " =- " -> Just q ) -> Right ( Eq , - q )
( parse " - " -> Just q ) -> Right ( Eq , - q )
-- number is unsigned and zero, do a signed comparison (more useful)
( parse " <= " -> Just 0 ) -> Right ( LtEq , 0 )
( parse " < " -> Just 0 ) -> Right ( Lt , 0 )
( parse " >= " -> Just 0 ) -> Right ( GtEq , 0 )
( parse " > " -> Just 0 ) -> Right ( Gt , 0 )
-- number is unsigned and non-zero, do an absolute magnitude comparison
( parse " <= " -> Just q ) -> Right ( AbsLtEq , q )
( parse " < " -> Just q ) -> Right ( AbsLt , q )
( parse " >= " -> Just q ) -> Right ( AbsGtEq , q )
( parse " > " -> Just q ) -> Right ( AbsGt , q )
( parse " = " -> Just q ) -> Right ( AbsEq , q )
( parse " " -> Just q ) -> Right ( AbsEq , q )
2020-12-27 02:52:39 +03:00
_ -> Left . T . unpack $
" could not parse as a comparison operator followed by an optionally-signed number: " <> amtarg
2013-09-09 22:57:25 +04:00
where
2020-08-05 03:39:48 +03:00
-- Strip outer whitespace from the text, require and remove the
-- specified prefix, remove all whitespace from the remainder, and
-- read it as a simple integer or decimal if possible.
parse :: T . Text -> T . Text -> Maybe Quantity
2020-12-27 02:52:39 +03:00
parse p s = ( T . stripPrefix p . T . strip ) s >>= readMay . T . unpack . T . filter ( /= ' ' )
2013-03-20 20:36:00 +04:00
2020-08-15 12:14:27 +03:00
parseTag :: T . Text -> Either RegexError Query
parseTag s = do
2020-12-27 02:52:39 +03:00
tag <- toRegexCI $ if T . null v then s else n
body <- if T . null v then pure Nothing else Just <$> toRegexCI ( T . tail v )
2020-08-15 12:14:27 +03:00
return $ Tag tag body
where ( n , v ) = T . break ( == '=' ) s
2012-05-28 04:27:55 +04:00
2022-01-30 22:32:52 +03:00
-- | Parse one or more account type code letters to a query matching any of those types.
parseTypeCodes :: T . Text -> Either String Query
parseTypeCodes s =
2022-01-30 15:45:19 +03:00
case partitionEithers $ map ( parseAccountType False . T . singleton ) $ T . unpack s of
2022-01-30 22:32:52 +03:00
( ( e : _ ) , _ ) -> Left $ " could not parse " <> show e <> " as an account type code. \ n " <> help
( [] , [] ) -> Left help
2022-01-30 15:45:19 +03:00
( [] , ts ) -> Right $ Type ts
2022-01-30 22:32:52 +03:00
where
help = " type:'s argument should be one or more of " ++ accountTypeChoices False ++ " (case insensitive). "
accountTypeChoices :: Bool -> String
accountTypeChoices allowlongform =
intercalate " , "
-- keep synced with parseAccountType
$ [ " A " , " L " , " E " , " R " , " X " , " C " , " V " ]
++ if allowlongform then [ " Asset " , " Liability " , " Equity " , " Revenue " , " Expense " , " Cash " , " Conversion " ] else []
2022-01-30 15:45:19 +03:00
2022-01-30 22:32:52 +03:00
-- | Case-insensitively parse one single-letter code, or one long-form word if permitted, to an account type.
-- On failure, returns the unparseable text.
2022-01-30 15:45:19 +03:00
parseAccountType :: Bool -> Text -> Either String AccountType
parseAccountType allowlongform s =
case T . toLower s of
2022-01-30 22:32:52 +03:00
-- keep synced with accountTypeChoices
2022-01-30 15:45:19 +03:00
" a " -> Right Asset
" l " -> Right Liability
" e " -> Right Equity
" r " -> Right Revenue
" x " -> Right Expense
" c " -> Right Cash
" v " -> Right Conversion
2022-01-30 22:32:52 +03:00
" asset " | allowlongform -> Right Asset
" liability " | allowlongform -> Right Liability
" equity " | allowlongform -> Right Equity
" revenue " | allowlongform -> Right Revenue
" expense " | allowlongform -> Right Expense
" cash " | allowlongform -> Right Cash
" conversion " | allowlongform -> Right Conversion
_ -> Left $ T . unpack s
2022-01-30 15:45:19 +03:00
2015-05-16 22:21:50 +03:00
-- | Parse the value part of a "status:" query, or return an error.
2017-06-16 02:54:34 +03:00
parseStatus :: T . Text -> Either String Status
2015-05-16 22:21:50 +03:00
parseStatus s | s ` elem ` [ " * " , " 1 " ] = Right Cleared
2017-06-16 02:25:37 +03:00
| s ` elem ` [ " " , " 0 " ] = Right Unmarked
2021-08-16 09:46:40 +03:00
| s == " ! " = Right Pending
2015-05-16 22:21:50 +03:00
| otherwise = Left $ " could not parse " ++ show s ++ " as a status (should be *, ! or empty) "
2011-06-13 23:46:35 +04:00
2014-12-25 10:48:23 +03:00
-- | Parse the boolean value part of a "status:" query. "1" means true,
-- anything else will be parsed as false without error.
2016-07-29 18:57:10 +03:00
parseBool :: T . Text -> Bool
2011-06-29 03:18:36 +04:00
parseBool s = s ` elem ` truestrings
2016-07-29 18:57:10 +03:00
truestrings :: [ T . Text ]
2014-12-25 10:48:23 +03:00
truestrings = [ " 1 " ]
2011-06-05 22:36:32 +04:00
2022-04-14 22:55:07 +03:00
-- * modifying
2012-05-17 20:02:22 +04:00
simplifyQuery :: Query -> Query
2022-08-23 13:58:31 +03:00
simplifyQuery q0 =
let q1 = simplify q0
in if q1 == q0 then q0 else simplifyQuery q1
2012-05-27 22:14:20 +04:00
where
simplify ( And [] ) = Any
simplify ( And [ q ] ) = simplify q
simplify ( And qs ) | same qs = simplify $ head qs
2021-08-23 10:14:14 +03:00
| None ` elem ` qs = None
2012-05-27 22:14:20 +04:00
| all queryIsDate qs = Date $ spansIntersect $ mapMaybe queryTermDateSpan qs
2021-08-16 09:46:40 +03:00
| otherwise = And $ map simplify dateqs ++ map simplify otherqs
2012-05-27 22:14:20 +04:00
where ( dateqs , otherqs ) = partition queryIsDate $ filter ( /= Any ) qs
simplify ( Or [] ) = Any
simplify ( Or [ q ] ) = simplifyQuery q
simplify ( Or qs ) | same qs = simplify $ head qs
2021-08-23 10:14:14 +03:00
| Any ` elem ` qs = Any
2012-05-27 22:14:20 +04:00
-- all queryIsDate qs = Date $ spansUnion $ mapMaybe queryTermDateSpan qs ?
| otherwise = Or $ map simplify $ filter ( /= None ) qs
simplify ( Date ( DateSpan Nothing Nothing ) ) = Any
2014-12-25 01:43:49 +03:00
simplify ( Date2 ( DateSpan Nothing Nothing ) ) = Any
2012-05-27 22:14:20 +04:00
simplify q = q
same [] = True
same ( a : as ) = all ( a == ) as
2021-12-10 01:57:26 +03:00
-- | Remove query terms (or whole sub-expressions) from this query
2022-04-14 22:55:07 +03:00
-- which do not match the given predicate. XXX Semantics not completely clear.
-- Also calls simplifyQuery on the result.
2012-05-27 22:14:20 +04:00
filterQuery :: ( Query -> Bool ) -> Query -> Query
2012-06-30 02:36:30 +04:00
filterQuery p = simplifyQuery . filterQuery' p
2022-04-14 22:55:07 +03:00
-- | Like filterQuery, but returns the filtered query as is, without simplifying.
filterQuery' :: ( Query -> Bool ) -> Query -> Query
filterQuery' p ( And qs ) = And $ map ( filterQuery p ) qs
filterQuery' p ( Or qs ) = Or $ map ( filterQuery p ) qs
filterQuery' p q = if p q then q else Any
2021-12-10 01:57:26 +03:00
-- | Remove query terms (or whole sub-expressions) from this query
-- which match neither the given predicate nor that predicate negated
-- (eg, if predicate is queryIsAcct, this will keep both "acct:" and "not:acct:" terms).
2022-04-14 22:55:07 +03:00
-- Also calls simplifyQuery on the result.
2021-12-10 01:57:26 +03:00
-- (Since 1.24.1, might be merged into filterQuery in future.)
-- XXX Semantics not completely clear.
filterQueryOrNotQuery :: ( Query -> Bool ) -> Query -> Query
2022-08-23 13:58:31 +03:00
filterQueryOrNotQuery p0 = simplifyQuery . filterQueryOrNotQuery' p0
2021-12-10 01:57:26 +03:00
where
2022-04-14 22:55:07 +03:00
filterQueryOrNotQuery' :: ( Query -> Bool ) -> Query -> Query
filterQueryOrNotQuery' p ( And qs ) = And $ map ( filterQueryOrNotQuery p ) qs
filterQueryOrNotQuery' p ( Or qs ) = Or $ map ( filterQueryOrNotQuery p ) qs
filterQueryOrNotQuery' p ( Not q ) | p q = Not $ filterQueryOrNotQuery p q
filterQueryOrNotQuery' p q = if p q then q else Any
2012-05-27 22:14:20 +04:00
2022-04-14 22:55:07 +03:00
-- * predicates
-- | Does this simple query predicate match any part of this possibly compound query ?
matchesQuery :: ( Query -> Bool ) -> Query -> Bool
matchesQuery p ( And qs ) = any ( matchesQuery p ) qs
matchesQuery p ( Or qs ) = any ( matchesQuery p ) qs
matchesQuery p ( Not q ) = p q
matchesQuery p q = p q
2012-05-16 12:28:02 +04:00
-- | Does this query match everything ?
2012-05-27 22:14:20 +04:00
queryIsNull :: Query -> Bool
2012-05-16 12:28:02 +04:00
queryIsNull Any = True
queryIsNull ( And [] ) = True
queryIsNull ( Not ( Or [] ) ) = True
queryIsNull _ = False
2022-04-14 23:46:57 +03:00
-- | Is this a simple query of this type (date:) ?
-- Does not match a compound query involving and/or/not.
2021-12-10 01:57:26 +03:00
-- Likewise for the following functions.
2012-05-27 22:14:20 +04:00
queryIsDate :: Query -> Bool
queryIsDate ( Date _ ) = True
queryIsDate _ = False
2014-12-25 03:11:30 +03:00
queryIsDate2 :: Query -> Bool
queryIsDate2 ( Date2 _ ) = True
queryIsDate2 _ = False
queryIsDateOrDate2 :: Query -> Bool
queryIsDateOrDate2 ( Date _ ) = True
queryIsDateOrDate2 ( Date2 _ ) = True
queryIsDateOrDate2 _ = False
2022-04-14 23:46:57 +03:00
queryIsStatus :: Query -> Bool
queryIsStatus ( StatusQ _ ) = True
queryIsStatus _ = False
queryIsCode :: Query -> Bool
queryIsCode ( Code _ ) = True
queryIsCode _ = False
2012-05-27 22:14:20 +04:00
queryIsDesc :: Query -> Bool
queryIsDesc ( Desc _ ) = True
queryIsDesc _ = False
2022-04-14 23:46:57 +03:00
queryIsTag :: Query -> Bool
queryIsTag ( Tag _ _ ) = True
queryIsTag _ = False
2012-05-27 22:14:20 +04:00
queryIsAcct :: Query -> Bool
queryIsAcct ( Acct _ ) = True
queryIsAcct _ = False
2012-05-16 12:28:02 +04:00
2022-04-14 23:46:57 +03:00
queryIsType :: Query -> Bool
queryIsType ( Type _ ) = True
queryIsType _ = False
2018-07-15 10:37:13 +03:00
2022-04-14 23:46:57 +03:00
queryIsDepth :: Query -> Bool
queryIsDepth ( Depth _ ) = True
queryIsDepth _ = False
2014-02-28 05:47:47 +04:00
2016-06-01 20:48:57 +03:00
queryIsReal :: Query -> Bool
queryIsReal ( Real _ ) = True
queryIsReal _ = False
2022-04-14 23:46:57 +03:00
queryIsAmt :: Query -> Bool
queryIsAmt ( Amt _ _ ) = True
queryIsAmt _ = False
2022-01-30 15:45:19 +03:00
2022-04-14 23:46:57 +03:00
queryIsSym :: Query -> Bool
queryIsSym ( Sym _ ) = True
queryIsSym _ = False
2022-01-29 08:56:49 +03:00
2012-05-16 12:28:02 +04:00
-- | Does this query specify a start date and nothing else (that would
-- filter postings prior to the date) ?
2012-12-06 08:43:41 +04:00
-- When the flag is true, look for a starting secondary date instead.
2012-05-16 12:28:02 +04:00
queryIsStartDateOnly :: Bool -> Query -> Bool
queryIsStartDateOnly _ Any = False
queryIsStartDateOnly _ None = False
2021-08-23 10:14:14 +03:00
queryIsStartDateOnly secondary ( Or ms ) = all ( queryIsStartDateOnly secondary ) ms
queryIsStartDateOnly secondary ( And ms ) = all ( queryIsStartDateOnly secondary ) ms
2012-05-16 12:28:02 +04:00
queryIsStartDateOnly False ( Date ( DateSpan ( Just _ ) _ ) ) = True
2012-12-06 08:43:41 +04:00
queryIsStartDateOnly True ( Date2 ( DateSpan ( Just _ ) _ ) ) = True
2012-05-16 12:28:02 +04:00
queryIsStartDateOnly _ _ = False
2022-04-14 23:46:57 +03:00
-- | Does this query involve a property of transactions (or their postings),
-- making it inapplicable to account declarations ?
queryIsTransactionRelated :: Query -> Bool
queryIsTransactionRelated = matchesQuery (
queryIsDate
2022-04-14 22:55:07 +03:00
||| queryIsDate2
||| queryIsStatus
2022-04-14 23:46:57 +03:00
||| queryIsCode
||| queryIsDesc
||| queryIsReal
||| queryIsAmt
||| queryIsSym
2022-04-14 22:55:07 +03:00
)
( ||| ) :: ( a -> Bool ) -> ( a -> Bool ) -> ( a -> Bool )
p ||| q = \ v -> p v || q v
-- * accessors
2012-12-06 08:43:41 +04:00
-- | What start date (or secondary date) does this query specify, if any ?
2012-05-27 22:14:20 +04:00
-- For OR expressions, use the earliest of the dates. NOT is ignored.
queryStartDate :: Bool -> Query -> Maybe Day
2012-12-06 08:43:41 +04:00
queryStartDate secondary ( Or ms ) = earliestMaybeDate $ map ( queryStartDate secondary ) ms
queryStartDate secondary ( And ms ) = latestMaybeDate $ map ( queryStartDate secondary ) ms
2012-05-27 22:14:20 +04:00
queryStartDate False ( Date ( DateSpan ( Just d ) _ ) ) = Just d
2012-12-06 08:43:41 +04:00
queryStartDate True ( Date2 ( DateSpan ( Just d ) _ ) ) = Just d
2012-05-27 22:14:20 +04:00
queryStartDate _ _ = Nothing
2014-07-15 18:01:01 +04:00
-- | What end date (or secondary date) does this query specify, if any ?
-- For OR expressions, use the latest of the dates. NOT is ignored.
queryEndDate :: Bool -> Query -> Maybe Day
queryEndDate secondary ( Or ms ) = latestMaybeDate' $ map ( queryEndDate secondary ) ms
queryEndDate secondary ( And ms ) = earliestMaybeDate' $ map ( queryEndDate secondary ) ms
queryEndDate False ( Date ( DateSpan _ ( Just d ) ) ) = Just d
queryEndDate True ( Date2 ( DateSpan _ ( Just d ) ) ) = Just d
queryEndDate _ _ = Nothing
2022-08-23 13:58:31 +03:00
queryTermDateSpan ( Date spn ) = Just spn
2012-05-27 22:14:20 +04:00
queryTermDateSpan _ = Nothing
2018-07-14 13:10:16 +03:00
-- | What date span (or with a true argument, what secondary date span) does this query specify ?
-- OR clauses specifying multiple spans return their union (the span enclosing all of them).
-- AND clauses specifying multiple spans return their intersection.
-- NOT clauses are ignored.
2012-05-27 22:14:20 +04:00
queryDateSpan :: Bool -> Query -> DateSpan
2018-07-14 13:10:16 +03:00
queryDateSpan secondary ( Or qs ) = spansUnion $ map ( queryDateSpan secondary ) qs
queryDateSpan secondary ( And qs ) = spansIntersect $ map ( queryDateSpan secondary ) qs
2022-08-23 13:58:31 +03:00
queryDateSpan _ ( Date spn ) = spn
queryDateSpan True ( Date2 spn ) = spn
2018-07-14 13:10:16 +03:00
queryDateSpan _ _ = nulldatespan
-- | What date span does this query specify, treating primary and secondary dates as equivalent ?
-- OR clauses specifying multiple spans return their union (the span enclosing all of them).
-- AND clauses specifying multiple spans return their intersection.
-- NOT clauses are ignored.
2014-12-25 03:11:30 +03:00
queryDateSpan' :: Query -> DateSpan
2018-07-14 13:10:16 +03:00
queryDateSpan' ( Or qs ) = spansUnion $ map queryDateSpan' qs
queryDateSpan' ( And qs ) = spansIntersect $ map queryDateSpan' qs
2022-08-23 13:58:31 +03:00
queryDateSpan' ( Date spn ) = spn
queryDateSpan' ( Date2 spn ) = spn
2018-07-14 13:10:16 +03:00
queryDateSpan' _ = nulldatespan
2014-12-25 03:11:30 +03:00
2019-11-29 05:09:05 +03:00
-- | What is the earliest of these dates, where Nothing is earliest ?
2012-05-16 12:28:02 +04:00
earliestMaybeDate :: [ Maybe Day ] -> Maybe Day
2020-07-16 12:30:18 +03:00
earliestMaybeDate = fromMaybe Nothing . minimumMay
2012-05-16 12:28:02 +04:00
-- | What is the latest of these dates, where Nothing is earliest ?
latestMaybeDate :: [ Maybe Day ] -> Maybe Day
2020-07-16 12:30:18 +03:00
latestMaybeDate = fromMaybe Nothing . maximumMay
2012-05-16 12:28:02 +04:00
2019-11-29 05:09:05 +03:00
-- | What is the earliest of these dates, where Nothing is the latest ?
2014-07-15 18:01:01 +04:00
earliestMaybeDate' :: [ Maybe Day ] -> Maybe Day
2020-07-16 12:30:18 +03:00
earliestMaybeDate' = fromMaybe Nothing . minimumMay . filter isJust
2014-07-15 18:01:01 +04:00
2019-11-29 05:09:05 +03:00
-- | What is the latest of these dates, where Nothing is the latest ?
2014-07-15 18:01:01 +04:00
latestMaybeDate' :: [ Maybe Day ] -> Maybe Day
2020-07-16 12:30:18 +03:00
latestMaybeDate' = fromMaybe Nothing . maximumByMay compareNothingMax
2019-11-29 05:09:05 +03:00
where
compareNothingMax Nothing Nothing = EQ
compareNothingMax ( Just _ ) Nothing = LT
compareNothingMax Nothing ( Just _ ) = GT
compareNothingMax ( Just a ) ( Just b ) = compare a b
2012-05-16 12:28:02 +04:00
2020-07-16 12:30:18 +03:00
-- | The depth limit this query specifies, if it has one
queryDepth :: Query -> Maybe Int
queryDepth = minimumMay . queryDepth'
2012-05-27 22:14:20 +04:00
where
queryDepth' ( Depth d ) = [ d ]
2020-07-16 12:30:18 +03:00
queryDepth' ( Or qs ) = concatMap queryDepth' qs
queryDepth' ( And qs ) = concatMap queryDepth' qs
queryDepth' _ = []
2012-05-27 22:14:20 +04:00
2012-05-16 12:28:02 +04:00
-- | The account we are currently focussed on, if any, and whether subaccounts are included.
-- Just looks at the first query option.
inAccount :: [ QueryOpt ] -> Maybe ( AccountName , Bool )
inAccount [] = Nothing
inAccount ( QueryOptInAcctOnly a : _ ) = Just ( a , False )
inAccount ( QueryOptInAcct a : _ ) = Just ( a , True )
-- | A query for the account(s) we are currently focussed on, if any.
-- Just looks at the first query option.
inAccountQuery :: [ QueryOpt ] -> Maybe Query
inAccountQuery [] = Nothing
2020-08-15 12:14:27 +03:00
inAccountQuery ( QueryOptInAcctOnly a : _ ) = Just . Acct $ accountNameToAccountOnlyRegex a
inAccountQuery ( QueryOptInAcct a : _ ) = Just . Acct $ accountNameToAccountRegex a
2012-05-16 12:28:02 +04:00
-- -- | Convert a query to its inverse.
-- negateQuery :: Query -> Query
-- negateQuery = Not
2022-04-14 22:55:07 +03:00
-- matching things with queries
2011-06-11 20:00:00 +04:00
2018-07-15 10:37:13 +03:00
matchesCommodity :: Query -> CommoditySymbol -> Bool
2020-12-27 02:52:39 +03:00
matchesCommodity ( Sym r ) = regexMatchText r
2020-08-15 12:14:27 +03:00
matchesCommodity _ = const True
2018-07-15 10:37:13 +03:00
2014-02-28 05:47:47 +04:00
-- | Does the match expression match this (simple) amount ?
matchesAmount :: Query -> Amount -> Bool
matchesAmount ( Not q ) a = not $ q ` matchesAmount ` a
matchesAmount ( Any ) _ = True
matchesAmount ( None ) _ = False
matchesAmount ( Or qs ) a = any ( ` matchesAmount ` a ) qs
matchesAmount ( And qs ) a = all ( ` matchesAmount ` a ) qs
2014-04-06 06:33:44 +04:00
matchesAmount ( Amt ord n ) a = compareAmount ord n a
2018-07-15 10:37:13 +03:00
matchesAmount ( Sym r ) a = matchesCommodity ( Sym r ) ( acommodity a )
2014-02-28 05:47:47 +04:00
matchesAmount _ _ = True
2014-04-06 06:33:44 +04:00
-- | Is this amount's quantity less than, greater than, equal to, or unsignedly equal to this number ?
compareAmount :: OrdPlus -> Quantity -> Amount -> Bool
2014-06-29 22:09:13 +04:00
compareAmount ord q Amount { aquantity = aq } = case ord of Lt -> aq < q
LtEq -> aq <= q
Gt -> aq > q
GtEq -> aq >= q
Eq -> aq == q
AbsLt -> abs aq < abs q
AbsLtEq -> abs aq <= abs q
AbsGt -> abs aq > abs q
AbsGtEq -> abs aq >= abs q
AbsEq -> abs aq == abs q
2014-02-28 05:47:47 +04:00
2022-01-30 15:45:19 +03:00
matchesMixedAmount :: Query -> MixedAmount -> Bool
matchesMixedAmount q ma = case amountsRaw ma of
[] -> q ` matchesAmount ` nullamt
as -> any ( q ` matchesAmount ` ) as
-- | Does the query match this account name ?
-- A matching in: clause is also considered a match.
matchesAccount :: Query -> AccountName -> Bool
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 = regexMatchText r a
matchesAccount ( Depth d ) a = accountNameLevel a <= d
matchesAccount ( Tag _ _ ) _ = False
matchesAccount _ _ = True
-- | Like matchesAccount, but with optional extra matching features:
--
-- - If the account's type is provided, any type: terms in the query
-- must match it (and any negated type: terms must not match it).
--
-- - If the account's tags are provided, any tag: terms must match
-- at least one of them (and any negated tag: terms must match none).
2017-01-13 19:02:11 +03:00
--
2022-02-01 08:37:38 +03:00
matchesAccountExtra :: ( AccountName -> Maybe AccountType ) -> ( AccountName -> [ Tag ] ) -> Query -> AccountName -> Bool
2022-02-03 12:22:38 +03:00
matchesAccountExtra atypes atags ( Not q ) a = not $ matchesAccountExtra atypes atags q a
matchesAccountExtra atypes atags ( Or qs ) a = any ( \ q -> matchesAccountExtra atypes atags q a ) qs
matchesAccountExtra atypes atags ( And qs ) a = all ( \ q -> matchesAccountExtra atypes atags q a ) qs
matchesAccountExtra atypes _ ( Type ts ) a = maybe False ( \ t -> any ( t ` isAccountSubtypeOf ` ) ts ) $ atypes a
2022-02-01 08:37:38 +03:00
matchesAccountExtra _ atags ( Tag npat vpat ) a = matchesTags npat vpat $ atags a
2022-02-03 12:22:38 +03:00
matchesAccountExtra _ _ q a = matchesAccount q a
2022-01-30 15:45:19 +03:00
-- | Does the match expression match this posting ?
-- When matching account name, and the posting has been transformed
-- in some way, we will match either the original or transformed name.
2012-05-16 11:12:49 +04:00
matchesPosting :: Query -> Posting -> Bool
2012-05-27 22:14:20 +04:00
matchesPosting ( Not q ) p = not $ q ` matchesPosting ` p
2012-05-16 11:12:49 +04:00
matchesPosting ( Any ) _ = True
matchesPosting ( None ) _ = False
2012-05-27 22:14:20 +04:00
matchesPosting ( Or qs ) p = any ( ` matchesPosting ` p ) qs
matchesPosting ( And qs ) p = all ( ` matchesPosting ` p ) qs
2020-12-27 02:52:39 +03:00
matchesPosting ( Code r ) p = maybe False ( regexMatchText r . tcode ) $ ptransaction p
matchesPosting ( Desc r ) p = maybe False ( regexMatchText r . tdescription ) $ ptransaction p
2022-01-30 15:45:19 +03:00
matchesPosting ( Acct r ) p = matches p || maybe False matches ( poriginal p ) where matches = regexMatchText r . paccount
2022-08-23 13:58:31 +03:00
matchesPosting ( Date spn ) p = spn ` spanContainsDate ` postingDate p
matchesPosting ( Date2 spn ) p = spn ` spanContainsDate ` postingDate2 p
2017-06-16 02:52:58 +03:00
matchesPosting ( StatusQ s ) p = postingStatus p == s
2012-05-16 11:12:49 +04:00
matchesPosting ( Real v ) p = v == isReal p
2014-04-06 06:33:44 +04:00
matchesPosting q @ ( Depth _ ) Posting { paccount = a } = q ` matchesAccount ` a
lib: Change internal representation of MixedAmount to use a strict Map
instead of a list of Amounts. No longer export Mixed constructor, to
keep API clean (if you really need it, you can import it directly from
Hledger.Data.Types). We also ensure the JSON representation of
MixedAmount doesn't change: it is stored as a normalised list of
Amounts.
This commit improves performance. Here are some indicative results.
hledger reg -f examples/10000x1000x10.journal
- Maximum residency decreases from 65MB to 60MB (8% decrease)
- Total memory in use decreases from 178MiB to 157MiB (12% decrease)
hledger reg -f examples/10000x10000x10.journal
- Maximum residency decreases from 69MB to 60MB (13% decrease)
- Total memory in use decreases from 198MiB to 153MiB (23% decrease)
hledger bal -f examples/10000x1000x10.journal
- Total heap usage decreases from 6.4GB to 6.0GB (6% decrease)
- Total memory in use decreases from 178MiB to 153MiB (14% decrease)
hledger bal -f examples/10000x10000x10.journal
- Total heap usage decreases from 7.3GB to 6.9GB (5% decrease)
- Total memory in use decreases from 196MiB to 185MiB (5% decrease)
hledger bal -M -f examples/10000x1000x10.journal
- Total heap usage decreases from 16.8GB to 10.6GB (47% decrease)
- Total time decreases from 14.3s to 12.0s (16% decrease)
hledger bal -M -f examples/10000x10000x10.journal
- Total heap usage decreases from 108GB to 48GB (56% decrease)
- Total time decreases from 62s to 41s (33% decrease)
If you never directly use the constructor Mixed or pattern match against
it then you don't need to make any changes. If you do, then do the
following:
- If you really care about the individual Amounts and never normalise
your MixedAmount (for example, just storing `Mixed amts` and then
extracting `amts` as a pattern match, then use should switch to using
[Amount]. This should just involve removing the `Mixed` constructor.
- If you ever call `mixed`, `normaliseMixedAmount`, or do any sort of
amount arithmetic (+), (-), then you should replace the constructor
`Mixed` with the function `mixed`. To extract the list of Amounts, use
the function `amounts`.
- If you ever call `normaliseMixedAmountSquashPricesForDisplay`, you can
replace that with `mixedAmountStripPrices`. (N.B. this does something
slightly different from `normaliseMixedAmountSquashPricesForDisplay`,
but I don't think there's any use case for squashing prices and then
keeping the first of the squashed prices around. If you disagree let
me know.)
- Any remaining calls to `normaliseMixedAmount` can be removed, as that
is now the identity function.
2021-01-29 08:07:11 +03:00
matchesPosting q @ ( Amt _ _ ) Posting { pamount = as } = q ` matchesMixedAmount ` as
2021-08-23 10:14:14 +03:00
matchesPosting ( Sym r ) Posting { pamount = as } = any ( matchesCommodity ( Sym r ) . acommodity ) $ amountsRaw as
2020-08-15 12:14:27 +03:00
matchesPosting ( Tag n v ) p = case ( reString n , v ) of
2022-08-23 13:58:31 +03:00
( " payee " , Just v' ) -> maybe False ( regexMatchText v' . transactionPayee ) $ ptransaction p
( " note " , Just v' ) -> maybe False ( regexMatchText v' . transactionNote ) $ ptransaction p
2022-01-29 08:56:49 +03:00
( _ , mv ) -> matchesTags n mv $ postingAllTags p
2022-01-30 15:45:19 +03:00
matchesPosting ( Type _ ) _ = False
-- | Like matchesPosting, but if the posting's account's type is provided,
-- any type: terms in the query must match it (and any negated type: terms
-- must not match it).
2022-02-01 08:37:38 +03:00
matchesPostingExtra :: ( AccountName -> Maybe AccountType ) -> Query -> Posting -> Bool
matchesPostingExtra atype ( Not q ) p = not $ matchesPostingExtra atype q p
matchesPostingExtra atype ( Or qs ) p = any ( \ q -> matchesPostingExtra atype q p ) qs
matchesPostingExtra atype ( And qs ) p = all ( \ q -> matchesPostingExtra atype q p ) qs
2022-02-03 12:22:38 +03:00
matchesPostingExtra atype ( Type ts ) p = maybe False ( \ t -> any ( t ` isAccountSubtypeOf ` ) ts ) . atype $ paccount p
matchesPostingExtra _ q p = matchesPosting q p
2011-06-05 22:36:32 +04:00
2011-06-11 20:00:00 +04:00
-- | Does the match expression match this transaction ?
2012-05-16 11:12:49 +04:00
matchesTransaction :: Query -> Transaction -> Bool
2012-05-27 22:14:20 +04:00
matchesTransaction ( Not q ) t = not $ q ` matchesTransaction ` t
2012-05-16 11:12:49 +04:00
matchesTransaction ( Any ) _ = True
matchesTransaction ( None ) _ = False
2012-05-27 22:14:20 +04:00
matchesTransaction ( Or qs ) t = any ( ` matchesTransaction ` t ) qs
matchesTransaction ( And qs ) t = all ( ` matchesTransaction ` t ) qs
2020-12-27 02:52:39 +03:00
matchesTransaction ( Code r ) t = regexMatchText r $ tcode t
matchesTransaction ( Desc r ) t = regexMatchText r $ tdescription t
2012-05-27 22:14:20 +04:00
matchesTransaction q @ ( Acct _ ) t = any ( q ` matchesPosting ` ) $ tpostings t
2022-08-23 13:58:31 +03:00
matchesTransaction ( Date spn ) t = spanContainsDate spn $ tdate t
matchesTransaction ( Date2 spn ) t = spanContainsDate spn $ transactionDate2 t
2017-06-16 02:52:58 +03:00
matchesTransaction ( StatusQ s ) t = tstatus t == s
2012-05-16 11:12:49 +04:00
matchesTransaction ( Real v ) t = v == hasRealPostings t
2013-03-20 20:36:00 +04:00
matchesTransaction q @ ( Amt _ _ ) t = any ( q ` matchesPosting ` ) $ tpostings t
2012-05-27 22:14:20 +04:00
matchesTransaction ( Depth d ) t = any ( Depth d ` matchesPosting ` ) $ tpostings t
2013-09-10 02:26:45 +04:00
matchesTransaction q @ ( Sym _ ) t = any ( q ` matchesPosting ` ) $ tpostings t
2020-08-15 12:14:27 +03:00
matchesTransaction ( Tag n v ) t = case ( reString n , v ) of
2022-08-23 13:58:31 +03:00
( " payee " , Just v' ) -> regexMatchText v' $ transactionPayee t
( " note " , Just v' ) -> regexMatchText v' $ transactionNote t
( _ , v' ) -> matchesTags n v' $ transactionAllTags t
2022-01-30 15:45:19 +03:00
matchesTransaction ( Type _ ) _ = False
-- | Like matchesTransaction, but if the journal's account types are provided,
-- any type: terms in the query must match at least one posting's account type
-- (and any negated type: terms must match none).
2022-02-01 08:37:38 +03:00
matchesTransactionExtra :: ( AccountName -> Maybe AccountType ) -> Query -> Transaction -> Bool
matchesTransactionExtra atype ( Not q ) t = not $ matchesTransactionExtra atype q t
matchesTransactionExtra atype ( Or qs ) t = any ( \ q -> matchesTransactionExtra atype q t ) qs
matchesTransactionExtra atype ( And qs ) t = all ( \ q -> matchesTransactionExtra atype q t ) qs
matchesTransactionExtra atype q @ ( Type _ ) t = any ( matchesPostingExtra atype q ) $ tpostings t
matchesTransactionExtra _ q t = matchesTransaction q t
2012-05-27 22:14:20 +04:00
2021-01-18 03:17:16 +03:00
-- | Does the query match this transaction description ?
-- Tests desc: terms, any other terms are ignored.
matchesDescription :: Query -> Text -> Bool
matchesDescription ( Not q ) d = not $ q ` matchesDescription ` d
matchesDescription ( Any ) _ = True
matchesDescription ( None ) _ = False
matchesDescription ( Or qs ) d = any ( ` matchesDescription ` d ) $ filter queryIsDesc qs
matchesDescription ( And qs ) d = all ( ` matchesDescription ` d ) $ filter queryIsDesc qs
matchesDescription ( Code _ ) _ = False
matchesDescription ( Desc r ) d = regexMatchText r d
2022-01-30 15:45:19 +03:00
matchesDescription _ _ = False
2021-01-18 03:17:16 +03:00
-- | Does the query match this transaction payee ?
-- Tests desc: (and payee: ?) terms, any other terms are ignored.
-- XXX Currently an alias for matchDescription. I'm not sure if more is needed,
-- There's some shenanigan with payee: and "payeeTag" to figure out.
matchesPayeeWIP :: Query -> Payee -> Bool
2021-08-16 09:46:40 +03:00
matchesPayeeWIP = matchesDescription
2021-01-18 03:17:16 +03:00
2020-08-07 17:53:00 +03:00
-- | Does the query match the name and optionally the value of any of these tags ?
2017-08-31 00:21:01 +03:00
matchesTags :: Regexp -> Maybe Regexp -> [ Tag ] -> Bool
2021-08-16 09:46:40 +03:00
matchesTags namepat valuepat = any ( matches namepat valuepat )
2020-08-07 17:53:00 +03:00
where
2020-12-27 02:52:39 +03:00
matches npat vpat ( n , v ) = regexMatchText npat n && maybe ( const True ) regexMatchText vpat v
2020-08-07 17:53:00 +03:00
2018-07-15 10:37:13 +03:00
-- | Does the query match this market price ?
2019-06-04 03:26:27 +03:00
matchesPriceDirective :: Query -> PriceDirective -> Bool
matchesPriceDirective ( None ) _ = False
matchesPriceDirective ( Not q ) p = not $ matchesPriceDirective q p
matchesPriceDirective ( Or qs ) p = any ( ` matchesPriceDirective ` p ) qs
matchesPriceDirective ( And qs ) p = all ( ` matchesPriceDirective ` p ) qs
matchesPriceDirective q @ ( Amt _ _ ) p = matchesAmount q ( pdamount p )
matchesPriceDirective q @ ( Sym _ ) p = matchesCommodity q ( pdcommodity p )
2022-08-23 13:58:31 +03:00
matchesPriceDirective ( Date spn ) p = spanContainsDate spn ( pddate p )
2019-06-04 03:26:27 +03:00
matchesPriceDirective _ _ = True
2018-07-15 10:37:13 +03:00
2012-05-17 18:59:38 +04:00
-- tests
2011-06-29 03:18:36 +04:00
2021-08-30 08:23:23 +03:00
tests_Query = testGroup " Query " [
testCase " simplifyQuery " $ do
2020-08-15 12:14:27 +03:00
( simplifyQuery $ Or [ Acct $ toRegex' " a " ] ) @?= ( Acct $ toRegex' " a " )
2019-11-27 23:46:29 +03:00
( simplifyQuery $ Or [ Any , None ] ) @?= ( Any )
( simplifyQuery $ And [ Any , None ] ) @?= ( None )
( simplifyQuery $ And [ Any , Any ] ) @?= ( Any )
2020-08-15 12:14:27 +03:00
( simplifyQuery $ And [ Acct $ toRegex' " b " , Any ] ) @?= ( Acct $ toRegex' " b " )
2019-11-27 23:46:29 +03:00
( simplifyQuery $ And [ Any , And [ Date ( DateSpan Nothing Nothing ) ] ] ) @?= ( Any )
2020-08-26 11:11:20 +03:00
( 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 ) ) )
2020-08-15 12:14:27 +03:00
( simplifyQuery $ And [ Or [] , Or [ Desc $ toRegex' " b b " ] ] ) @?= ( Desc $ toRegex' " b b " )
2019-11-27 23:46:29 +03:00
2021-08-30 08:23:23 +03:00
, testCase " parseQuery " $ do
2020-08-15 12:14:27 +03:00
( parseQuery nulldate " acct:'expenses:autres d \ 233 penses' desc:b " ) @?= Right ( And [ Acct $ toRegexCI' " expenses:autres d \ 233 penses " , Desc $ toRegexCI' " b " ] , [] )
parseQuery nulldate " inacct:a desc: \ " b b \ " " @?= Right ( Desc $ toRegexCI' " b b " , [ QueryOptInAcct " a " ] )
2020-08-05 23:41:13 +03:00
parseQuery nulldate " inacct:a inacct:b " @?= Right ( Any , [ QueryOptInAcct " a " , QueryOptInAcct " b " ] )
2020-08-15 12:14:27 +03:00
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' " \ " " , [] )
2019-11-27 23:46:29 +03:00
2021-08-30 08:23:23 +03:00
, testCase " words'' " $ do
2019-11-27 23:46:29 +03:00
( words'' [] " a b " ) @?= [ " a " , " b " ]
( words'' [] " 'a b' " ) @?= [ " a b " ]
( words'' [] " not:a b " ) @?= [ " not:a " , " b " ]
( words'' [] " not:'a b' " ) @?= [ " not:a b " ]
( words'' [] " 'not:a b' " ) @?= [ " not:a b " ]
( words'' [ " desc: " ] " not:desc:'a b' " ) @?= [ " not:desc:a b " ]
2022-08-23 13:58:31 +03:00
( words'' queryprefixes " \ " acct:expenses:autres d \ 233 penses \ " " ) @?= [ " acct:expenses:autres d \ 233 penses " ]
( words'' queryprefixes " \ " " ) @?= [ " \ " " ]
2019-11-27 23:46:29 +03:00
2021-08-30 08:23:23 +03:00
, testCase " filterQuery " $ do
2019-11-27 23:46:29 +03:00
filterQuery queryIsDepth Any @?= Any
filterQuery queryIsDepth ( Depth 1 ) @?= Depth 1
filterQuery ( not . queryIsDepth ) ( And [ And [ StatusQ Cleared , Depth 1 ] ] ) @?= StatusQ Cleared
filterQuery queryIsDepth ( And [ Date nulldatespan , Not ( Or [ Any , Depth 1 ] ) ] ) @?= Any -- XXX unclear
2021-08-30 08:23:23 +03:00
, testCase " parseQueryTerm " $ do
2020-08-15 12:14:27 +03:00
parseQueryTerm nulldate " a " @?= Right ( Left $ Acct $ toRegexCI' " a " )
parseQueryTerm nulldate " acct:expenses:autres d \ 233 penses " @?= Right ( Left $ Acct $ toRegexCI' " expenses:autres d \ 233 penses " )
parseQueryTerm nulldate " not:desc:a b " @?= Right ( Left $ Not $ Desc $ toRegexCI' " a b " )
2020-08-05 23:41:13 +03:00
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 )
2020-08-15 12:14:27 +03:00
parseQueryTerm nulldate " payee:x " @?= Left <$> payeeTag ( Just " x " )
parseQueryTerm nulldate " note:x " @?= Left <$> noteTag ( Just " x " )
2020-08-05 23:41:13 +03:00
parseQueryTerm nulldate " real:1 " @?= Right ( Left $ Real True )
2020-08-26 11:11:20 +03:00
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 ) )
2020-08-05 23:41:13 +03:00
parseQueryTerm nulldate " inacct:a " @?= Right ( Right $ QueryOptInAcct " a " )
2020-08-15 12:14:27 +03:00
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 " ) )
2020-08-05 23:41:13 +03:00
parseQueryTerm nulldate " amt:<0 " @?= Right ( Left $ Amt Lt 0 )
parseQueryTerm nulldate " amt:>10000.10 " @?= Right ( Left $ Amt AbsGt 10000.1 )
2019-11-27 23:46:29 +03:00
2021-08-30 08:23:23 +03:00
, testCase " parseAmountQueryTerm " $ do
2020-08-05 03:39:48 +03:00
parseAmountQueryTerm " <0 " @?= Right ( Lt , 0 ) -- special case for convenience, since AbsLt 0 would be always false
parseAmountQueryTerm " >0 " @?= Right ( Gt , 0 ) -- special case for convenience and consistency with above
2020-08-05 04:01:31 +03:00
parseAmountQueryTerm " > - 0 " @?= Right ( Gt , 0 ) -- accept whitespace around the argument parts
2020-08-05 03:39:48 +03:00
parseAmountQueryTerm " >10000.10 " @?= Right ( AbsGt , 10000.1 )
parseAmountQueryTerm " =0.23 " @?= Right ( AbsEq , 0.23 )
parseAmountQueryTerm " 0.23 " @?= Right ( AbsEq , 0.23 )
parseAmountQueryTerm " <=+0.23 " @?= Right ( LtEq , 0.23 )
parseAmountQueryTerm " -0.23 " @?= Right ( Eq , ( - 0.23 ) )
assertLeft $ parseAmountQueryTerm " -0,23 "
assertLeft $ parseAmountQueryTerm " =.23 "
2019-11-27 23:46:29 +03:00
2021-08-30 08:23:23 +03:00
, testCase " queryStartDate " $ do
2019-11-29 05:09:05 +03:00
let small = Just $ fromGregorian 2000 01 01
big = Just $ fromGregorian 2000 01 02
queryStartDate False ( And [ Date $ DateSpan small Nothing , Date $ DateSpan big Nothing ] ) @?= big
queryStartDate False ( And [ Date $ DateSpan small Nothing , Date $ DateSpan Nothing Nothing ] ) @?= small
queryStartDate False ( Or [ Date $ DateSpan small Nothing , Date $ DateSpan big Nothing ] ) @?= small
queryStartDate False ( Or [ Date $ DateSpan small Nothing , Date $ DateSpan Nothing Nothing ] ) @?= Nothing
2021-08-30 08:23:23 +03:00
, testCase " queryEndDate " $ do
2019-11-29 05:09:05 +03:00
let small = Just $ fromGregorian 2000 01 01
big = Just $ fromGregorian 2000 01 02
queryEndDate False ( And [ Date $ DateSpan Nothing small , Date $ DateSpan Nothing big ] ) @?= small
queryEndDate False ( And [ Date $ DateSpan Nothing small , Date $ DateSpan Nothing Nothing ] ) @?= small
queryEndDate False ( Or [ Date $ DateSpan Nothing small , Date $ DateSpan Nothing big ] ) @?= big
queryEndDate False ( Or [ Date $ DateSpan Nothing small , Date $ DateSpan Nothing Nothing ] ) @?= Nothing
2021-08-30 08:23:23 +03:00
, testCase " matchesAccount " $ do
2020-08-15 12:14:27 +03:00
assertBool " " $ ( Acct $ toRegex' " b:c " ) ` matchesAccount ` " a:bb:c:d "
assertBool " " $ not $ ( Acct $ toRegex' " ^a:b " ) ` matchesAccount ` " c:a:b "
2019-11-27 23:46:29 +03:00
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 "
2020-08-15 12:14:27 +03:00
assertBool " " $ not $ Tag ( toRegex' " a " ) Nothing ` matchesAccount ` " a "
2019-07-15 13:28:52 +03:00
2022-01-30 15:45:19 +03:00
, testCase " matchesAccountExtra " $ do
2022-01-29 08:56:49 +03:00
let tagq = Tag ( toRegexCI' " type " ) Nothing
2022-02-01 08:37:38 +03:00
assertBool " " $ not $ matchesAccountExtra ( const Nothing ) ( const [] ) tagq " a "
assertBool " " $ matchesAccountExtra ( const Nothing ) ( const [ ( " type " , " " ) ] ) tagq " a "
2022-01-29 08:56:49 +03:00
2021-08-30 08:23:23 +03:00
, testGroup " matchesPosting " [
testCase " positive match on cleared posting status " $
2019-11-27 23:46:29 +03:00
assertBool " " $ ( StatusQ Cleared ) ` matchesPosting ` nullposting { pstatus = Cleared }
2021-08-30 08:23:23 +03:00
, testCase " negative match on cleared posting status " $
2019-11-27 23:46:29 +03:00
assertBool " " $ not $ ( Not $ StatusQ Cleared ) ` matchesPosting ` nullposting { pstatus = Cleared }
2021-08-30 08:23:23 +03:00
, testCase " positive match on unmarked posting status " $
2019-11-27 23:46:29 +03:00
assertBool " " $ ( StatusQ Unmarked ) ` matchesPosting ` nullposting { pstatus = Unmarked }
2021-08-30 08:23:23 +03:00
, testCase " negative match on unmarked posting status " $
2019-11-27 23:46:29 +03:00
assertBool " " $ not $ ( Not $ StatusQ Unmarked ) ` matchesPosting ` nullposting { pstatus = Unmarked }
2021-08-30 08:23:23 +03:00
, testCase " positive match on true posting status acquired from transaction " $
2019-11-27 23:46:29 +03:00
assertBool " " $ ( StatusQ Cleared ) ` matchesPosting ` nullposting { pstatus = Unmarked , ptransaction = Just nulltransaction { tstatus = Cleared } }
2021-08-30 08:23:23 +03:00
, testCase " real:1 on real posting " $ assertBool " " $ ( Real True ) ` matchesPosting ` nullposting { ptype = RegularPosting }
, testCase " real:1 on virtual posting fails " $ assertBool " " $ not $ ( Real True ) ` matchesPosting ` nullposting { ptype = VirtualPosting }
, testCase " real:1 on balanced virtual posting fails " $ assertBool " " $ not $ ( Real True ) ` matchesPosting ` nullposting { ptype = BalancedVirtualPosting }
, testCase " acct: " $ assertBool " " $ ( Acct $ toRegex' " 'b " ) ` matchesPosting ` nullposting { paccount = " 'b " }
, testCase " tag: " $ do
2020-08-15 12:14:27 +03:00
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 " ) ] }
2021-08-30 08:23:23 +03:00
, testCase " a tag match on a posting also sees inherited tags " $ assertBool " " $ ( Tag ( toRegex' " txntag " ) Nothing ) ` matchesPosting ` nullposting { ptransaction = Just nulltransaction { ttags = [ ( " txntag " , " " ) ] } }
, testCase " cur: " $ do
2021-08-16 09:46:40 +03:00
let toSym = fromLeft ( error ' " N o q u e r y o p t s " ) . e i t h e r e r r o r' id . parseQueryTerm ( fromGregorian 2000 01 01 ) . ( " cur: " <> )
lib: Change internal representation of MixedAmount to use a strict Map
instead of a list of Amounts. No longer export Mixed constructor, to
keep API clean (if you really need it, you can import it directly from
Hledger.Data.Types). We also ensure the JSON representation of
MixedAmount doesn't change: it is stored as a normalised list of
Amounts.
This commit improves performance. Here are some indicative results.
hledger reg -f examples/10000x1000x10.journal
- Maximum residency decreases from 65MB to 60MB (8% decrease)
- Total memory in use decreases from 178MiB to 157MiB (12% decrease)
hledger reg -f examples/10000x10000x10.journal
- Maximum residency decreases from 69MB to 60MB (13% decrease)
- Total memory in use decreases from 198MiB to 153MiB (23% decrease)
hledger bal -f examples/10000x1000x10.journal
- Total heap usage decreases from 6.4GB to 6.0GB (6% decrease)
- Total memory in use decreases from 178MiB to 153MiB (14% decrease)
hledger bal -f examples/10000x10000x10.journal
- Total heap usage decreases from 7.3GB to 6.9GB (5% decrease)
- Total memory in use decreases from 196MiB to 185MiB (5% decrease)
hledger bal -M -f examples/10000x1000x10.journal
- Total heap usage decreases from 16.8GB to 10.6GB (47% decrease)
- Total time decreases from 14.3s to 12.0s (16% decrease)
hledger bal -M -f examples/10000x10000x10.journal
- Total heap usage decreases from 108GB to 48GB (56% decrease)
- Total time decreases from 62s to 41s (33% decrease)
If you never directly use the constructor Mixed or pattern match against
it then you don't need to make any changes. If you do, then do the
following:
- If you really care about the individual Amounts and never normalise
your MixedAmount (for example, just storing `Mixed amts` and then
extracting `amts` as a pattern match, then use should switch to using
[Amount]. This should just involve removing the `Mixed` constructor.
- If you ever call `mixed`, `normaliseMixedAmount`, or do any sort of
amount arithmetic (+), (-), then you should replace the constructor
`Mixed` with the function `mixed`. To extract the list of Amounts, use
the function `amounts`.
- If you ever call `normaliseMixedAmountSquashPricesForDisplay`, you can
replace that with `mixedAmountStripPrices`. (N.B. this does something
slightly different from `normaliseMixedAmountSquashPricesForDisplay`,
but I don't think there's any use case for squashing prices and then
keeping the first of the squashed prices around. If you disagree let
me know.)
- Any remaining calls to `normaliseMixedAmount` can be removed, as that
is now the identity function.
2021-01-29 08:07:11 +03:00
assertBool " " $ not $ toSym " $ " ` matchesPosting ` nullposting { pamount = mixedAmount $ usd 1 } -- becomes "^$$", ie testing for null symbol
assertBool " " $ ( toSym " \ \ $ " ) ` matchesPosting ` nullposting { pamount = mixedAmount $ usd 1 } -- have to quote $ for regexpr
assertBool " " $ ( toSym " shekels " ) ` matchesPosting ` nullposting { pamount = mixedAmount nullamt { acommodity = " shekels " } }
assertBool " " $ not $ ( toSym " shek " ) ` matchesPosting ` nullposting { pamount = mixedAmount nullamt { acommodity = " shekels " } }
2018-09-04 17:29:48 +03:00
]
2019-07-15 13:28:52 +03:00
2021-08-30 08:23:23 +03:00
, testCase " matchesTransaction " $ do
2019-11-27 23:46:29 +03:00
assertBool " " $ Any ` matchesTransaction ` nulltransaction
2020-08-15 12:14:27 +03:00
assertBool " " $ not $ ( Desc $ toRegex' " x x " ) ` matchesTransaction ` nulltransaction { tdescription = " x " }
assertBool " " $ ( Desc $ toRegex' " x x " ) ` matchesTransaction ` nulltransaction { tdescription = " x x " }
2018-09-04 17:29:48 +03:00
-- see posting for more tag tests
2020-08-15 12:14:27 +03:00
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 " }
2018-09-04 17:29:48 +03:00
-- a tag match on a transaction also matches posting tags
2020-08-15 12:14:27 +03:00
assertBool " " $ ( Tag ( toRegex' " postingtag " ) Nothing ) ` matchesTransaction ` nulltransaction { tpostings = [ nullposting { ptags = [ ( " postingtag " , " " ) ] } ] }
2011-09-21 04:28:32 +04:00
2018-09-04 17:29:48 +03:00
]