Merge 41821ccc76 into 94f9e6f303
This commit is contained in:
yantar92
GitHub
commit
52c26413f1
2 changed files with 199 additions and 59 deletions
143
org-ql.el
143
org-ql.el
|
|
@ -515,7 +515,8 @@ If NARROW is non-nil, buffer will not be widened."
|
|||
(unless narrow
|
||||
(widen))
|
||||
(goto-char (point-min))
|
||||
(when (org-before-first-heading-p)
|
||||
(when (and (org-before-first-heading-p)
|
||||
(not (org-at-heading-p)))
|
||||
(outline-next-heading))
|
||||
(if (not (org-at-heading-p))
|
||||
(progn
|
||||
|
|
@ -564,6 +565,7 @@ Returns cons (INHERITED-TAGS . LOCAL-TAGS)."
|
|||
'org-ql-nil))
|
||||
(inherited-tags (or (when org-use-tag-inheritance
|
||||
(save-excursion
|
||||
(org-with-wide-buffer
|
||||
(if (org-up-heading-safe)
|
||||
;; Return parent heading's tags.
|
||||
(-let* (((inherited local) (org-ql--tags-at (point)))
|
||||
|
|
@ -582,7 +584,7 @@ Returns cons (INHERITED-TAGS . LOCAL-TAGS)."
|
|||
('nil tags)
|
||||
(_ (-difference tags org-tags-exclude-from-inheritance))))
|
||||
;; Top-level heading: use file tags.
|
||||
org-file-tags)))
|
||||
org-file-tags))))
|
||||
'org-ql-nil))
|
||||
(all-tags (list inherited-tags local-tags)))
|
||||
;; Check caches again, because they may have been set now.
|
||||
|
|
@ -951,18 +953,8 @@ This function is defined by calling
|
|||
defined in `org-ql-predicates' by calling `org-ql-defpred'."
|
||||
(cl-labels ((rec (element)
|
||||
(pcase element
|
||||
(`(or . ,clauses) `(or ,@(mapcar #'rec clauses)))
|
||||
(`(and . ,clauses) `(and ,@(mapcar #'rec clauses)))
|
||||
(`(not . ,clauses) `(not ,@(mapcar #'rec clauses)))
|
||||
(`(when ,condition . ,clauses) `(when ,(rec condition)
|
||||
,@(mapcar #'rec clauses)))
|
||||
(`(unless ,condition . ,clauses) `(unless ,(rec condition)
|
||||
,@(mapcar #'rec clauses)))
|
||||
;; TODO: Combine (regexp) when appropriate (i.e. inside an OR, not an AND).
|
||||
((pred stringp) `(regexp ,element))
|
||||
|
||||
,@normalizer-patterns
|
||||
|
||||
;; Any other form: passed through unchanged.
|
||||
(_ element))))
|
||||
;; Repeat normalization until result doesn't change (limiting to 10 in case of an infinite-loop bug).
|
||||
|
|
@ -984,12 +976,7 @@ PREDICATES should be the value of `org-ql-predicates'."
|
|||
;; NOTE: Using -let instead of pcase-let here because I can't make map 2.1 install in the test sandbox.
|
||||
(--map (-let* (((&plist :preambles) (cdr it)))
|
||||
(--map (pcase-let* ((`(,pattern ,exp) it))
|
||||
`(,pattern
|
||||
(-let* (((&plist :regexp :case-fold :query) ,exp))
|
||||
(setf org-ql-preamble regexp
|
||||
preamble-case-fold case-fold)
|
||||
;; NOTE: Even when `predicate' is nil, it must be returned in the pcase form.
|
||||
query)))
|
||||
`(,pattern ,exp))
|
||||
preambles))
|
||||
predicates)))))
|
||||
(fset 'org-ql--query-preamble
|
||||
|
|
@ -1014,30 +1001,21 @@ This function is defined by calling
|
|||
defined in `org-ql-predicates' by calling `org-ql-defpred'."
|
||||
(pcase org-ql-use-preamble
|
||||
('nil (list :query query :preamble nil))
|
||||
(_ (let ((preamble-case-fold t)
|
||||
org-ql-preamble)
|
||||
(cl-labels ((rec (element)
|
||||
(or (when org-ql-preamble
|
||||
;; Only one preamble is allowed
|
||||
element)
|
||||
(_ (cl-labels ((rec (element)
|
||||
(pcase element
|
||||
(`(or _) element)
|
||||
|
||||
,@preamble-patterns
|
||||
|
||||
(`(and . ,rest)
|
||||
(let ((clauses (mapcar #'rec rest)))
|
||||
`(and ,@(-non-nil clauses))))
|
||||
(_ element)))))
|
||||
(setq query (pcase (mapcar #'rec (list query))
|
||||
((or `(nil)
|
||||
(_ (list :query element)))))
|
||||
(-let* (((&plist :regexp :case-fold :query) (funcall #'rec query)))
|
||||
(setq query (pcase query
|
||||
((or `nil
|
||||
`(nil)
|
||||
`((nil))
|
||||
`((and))
|
||||
`((or)))
|
||||
t)
|
||||
(`(t) t)
|
||||
(query (-flatten-n 1 query))))
|
||||
(list :query query :preamble org-ql-preamble :preamble-case-fold preamble-case-fold)))))))
|
||||
(_ query)))
|
||||
(list :query query :preamble regexp :preamble-case-fold case-fold)))))))
|
||||
;; For some reason, byte-compiling the backquoted lambda form directly causes a warning
|
||||
;; that `query' refers to an unbound variable, even though that's not the case, and the
|
||||
;; function still works. But to avoid the warning, we byte-compile it afterward.
|
||||
|
|
@ -1234,6 +1212,93 @@ result form."
|
|||
;; redefinitions until all of the predicates have been defined.
|
||||
(setf org-ql-defpred-defer t)
|
||||
|
||||
(org-ql-defpred org-ql--and (&rest _)
|
||||
"Normalizers and preambles for boolean (and ...) query."
|
||||
:normalizers ((`(and)
|
||||
nil)
|
||||
(`(and . ,clauses)
|
||||
`(and ,@(mapcar #'rec clauses))))
|
||||
:preambles ((`(and . ,clauses)
|
||||
(let ((preambles (mapcar #'rec clauses))
|
||||
regexps regexp-max case-fold-max queries)
|
||||
(cl-loop for preamble in preambles
|
||||
for clause in clauses
|
||||
do
|
||||
(-let* (((&plist :regexp :case-fold :query) preamble))
|
||||
(if regexp
|
||||
(when (or (not query) (eq query t))
|
||||
(setq query `(regexp ,regexp)))
|
||||
(unless query (setq query clause)))
|
||||
(push query queries)
|
||||
;; Take the longest regexp. It should be hardest to match.
|
||||
(when (length> regexp (length regexp-max))
|
||||
(setq regexp-max regexp)
|
||||
(setq case-fold-max case-fold))))
|
||||
(setq queries (reverse queries))
|
||||
(list :regexp regexp-max
|
||||
:case-fold case-fold-max
|
||||
:query `(and ,@queries))))))
|
||||
|
||||
(org-ql-defpred org-ql--or (&rest _)
|
||||
"Normalizers and preambles for boolean (or ...) query."
|
||||
:normalizers ((`(or)
|
||||
nil)
|
||||
(`(or . ,clauses)
|
||||
`(or ,@(mapcar #'rec clauses))))
|
||||
:preambles ((`(or . ,clauses)
|
||||
(let ((preambles (mapcar #'rec clauses))
|
||||
regexps regexp-null-p queries)
|
||||
(cl-loop for preamble in preambles
|
||||
for clause in clauses
|
||||
do
|
||||
(-let* (((&plist :regexp :case-fold :query) preamble))
|
||||
(if regexp
|
||||
(when (or (not query) (eq query t))
|
||||
(setq query `(regexp ,regexp)))
|
||||
(unless query (setq query clause)))
|
||||
(push query queries)
|
||||
;; Collect regexps for combining.
|
||||
(if regexp (push regexp regexps)
|
||||
(setq regexp-null-p t))))
|
||||
(setq queries (reverse queries))
|
||||
(list :regexp (unless regexp-null-p
|
||||
(and regexps
|
||||
(rx-to-string `(or ,@(mapcar (lambda (re) `(regex ,re)) regexps)))))
|
||||
:case-fold t
|
||||
:query `(or ,@queries))))))
|
||||
|
||||
(org-ql-defpred org-ql--when (&rest _)
|
||||
"Normalizers and preambles for (when ...) query."
|
||||
:normalizers
|
||||
((`(when ,condition . ,clauses)
|
||||
`(when ,(rec condition)
|
||||
,@(mapcar #'rec clauses))))
|
||||
:preambles
|
||||
((`(when ,condition . ,clauses)
|
||||
(-let* (((&plist :regexp :case-fold :query) (rec `(and ,condition ,(car (last clauses))))))
|
||||
(list :regexp regexp
|
||||
:case-fold case-fold
|
||||
:query `(when ,condition ,@clauses))))))
|
||||
|
||||
(org-ql-defpred org-ql--unless (&rest _)
|
||||
"Normalizers and preambles for (unless ...) query."
|
||||
:normalizers
|
||||
((`(unless ,condition . ,clauses)
|
||||
`(unless (save-excursion ,(rec condition))
|
||||
,@(mapcar #'rec clauses))))
|
||||
:preambles
|
||||
((`(unless ,condition . ,clauses)
|
||||
(-let* (((&plist :regexp :case-fold :query) (rec ,(car (last clauses)))))
|
||||
(list :regexp regexp
|
||||
:case-fold case-fold
|
||||
:query `(unless ,condition ,@clauses))))))
|
||||
|
||||
(org-ql-defpred org-ql--not (_)
|
||||
"Normalizers and preambles for (not ...) query."
|
||||
:normalizers
|
||||
((`(not . ,clauses)
|
||||
`(save-excursion (not ,@(mapcar #'rec clauses))))))
|
||||
|
||||
(org-ql-defpred category (&rest categories)
|
||||
"Return non-nil if current heading is in one or more of CATEGORIES (a list of strings)."
|
||||
:body (when-let ((category (org-get-category (point))))
|
||||
|
|
@ -1750,10 +1815,10 @@ Tests both inherited and local tags."
|
|||
(org-ql-defpred (tags-inherited inherited-tags tags-i itags) (&rest tags)
|
||||
"Return non-nil if current heading's inherited tags include one or more of TAGS (a list of strings).
|
||||
If TAGS is nil, return non-nil if heading has any inherited tags."
|
||||
:normalizers ((`(,predicate-names . ,tags)
|
||||
`(tags-inherited ,@tags))
|
||||
(`(,predicate-names)
|
||||
`(tags-inherited)))
|
||||
:normalizers ((`(,predicate-names)
|
||||
`(tags-inherited))
|
||||
(`(,predicate-names . ,tags)
|
||||
`(tags-inherited ,@tags)))
|
||||
:body (cl-macrolet ((tags-p (tags)
|
||||
`(and ,tags
|
||||
(not (eq 'org-ql-nil ,tags)))))
|
||||
|
|
|
|||
|
|
@ -469,6 +469,11 @@ with keyword arg NOW in PLIST."
|
|||
(expect (org-ql--normalize-query '(and (todo "TODO")
|
||||
(or "string1" "string2")))
|
||||
:to-equal '(and (todo "TODO") (or (regexp "string1") (regexp "string2"))))
|
||||
(expect (org-ql--normalize-query '(or (todo "TODO")
|
||||
(or "string1" "string2")))
|
||||
:to-equal '(or (todo "TODO") (or (regexp "string1") (regexp "string2"))))
|
||||
(expect (org-ql--normalize-query '(not (or "string1" "string2")))
|
||||
:to-equal '(not (or (regexp "string1") (regexp "string2"))))
|
||||
(expect (org-ql--normalize-query '(when (todo "TODO")
|
||||
(or "string1" "string2")))
|
||||
:to-equal '(when (todo "TODO") (or (regexp "string1") (regexp "string2"))))
|
||||
|
|
@ -517,6 +522,76 @@ with keyword arg NOW in PLIST."
|
|||
|
||||
;; TODO: Other predicates.
|
||||
|
||||
(describe "(and)"
|
||||
(it "all clauses have preambles"
|
||||
(expect (org-ql--query-preamble '(and (regexp "a") (regexp "b")))
|
||||
:to-equal (list :query '(and (regexp "a") (regexp "b"))
|
||||
:preamble "a"
|
||||
:preamble-case-fold t)))
|
||||
(it "some clauses miss preambles"
|
||||
(expect (org-ql--query-preamble '(and (regexp "a") (+ 1 1)))
|
||||
:to-equal (list :query '(and (regexp "a") (+ 1 1))
|
||||
:preamble "a"
|
||||
:preamble-case-fold t)))
|
||||
(it "all clauses don't have preambles"
|
||||
(expect (org-ql--query-preamble '(and t (+ 1 1)))
|
||||
:to-equal (list :query '(and t (+ 1 1))
|
||||
:preamble nil
|
||||
:preamble-case-fold nil))))
|
||||
|
||||
(describe "(or)"
|
||||
(it "all clauses have preambles"
|
||||
(expect (org-ql--query-preamble '(or (regexp "a") (regexp "b")))
|
||||
:to-equal (list :query '(or (regexp "a") (regexp "b"))
|
||||
:preamble (rx-to-string `(or (regexp "b") (regexp "a")))
|
||||
:preamble-case-fold t)))
|
||||
(it "some clauses miss preambles"
|
||||
(expect (org-ql--query-preamble '(or (regexp "a") (+ 1 1)))
|
||||
:to-equal (list :query '(or (regexp "a") (+ 1 1))
|
||||
:preamble nil
|
||||
:preamble-case-fold t)))
|
||||
(it "all clauses don't have preambles"
|
||||
(expect (org-ql--query-preamble '(or t (+ 1 1)))
|
||||
:to-equal (list :query '(or t (+ 1 1))
|
||||
:preamble nil
|
||||
:preamble-case-fold t))))
|
||||
|
||||
(describe "(when)"
|
||||
(it "simple query"
|
||||
(expect (org-ql--query-preamble '(when (regexp "a") (regexp "b")))
|
||||
:to-equal (list :query '(when (regexp "a") (regexp "b"))
|
||||
:preamble "a"
|
||||
:preamble-case-fold t)))
|
||||
(it "multiple clauses after when"
|
||||
(expect (org-ql--query-preamble '(when (regexp "a") (+ 1 1) (regexp "b")))
|
||||
:to-equal (list :query '(when (regexp "a") (+ 1 1) (regexp "b"))
|
||||
:preamble "a"
|
||||
:preamble-case-fold t)))
|
||||
(it "no preambles in clauses"
|
||||
(expect (org-ql--query-preamble '(when t (+ 1 1)))
|
||||
:to-equal (list :query '(when t (+ 1 1))
|
||||
:preamble nil
|
||||
:preamble-case-fold nil))))
|
||||
|
||||
(describe "(unless)"
|
||||
(it "simple query"
|
||||
(expect (org-ql--query-preamble '(unless (regexp "a") (regexp "b")))
|
||||
:to-equal (list :query '(unless (regexp "a") (regexp "b"))
|
||||
:preamble "b"
|
||||
:preamble-case-fold t)))
|
||||
(it "no predicate in last clause"
|
||||
(expect (org-ql--query-preamble '(unless (regexp "a") (regexp "b") (+ 1 1)))
|
||||
:to-equal (list :query '(unless (regexp "a") (regexp "b") (+ 1 1))
|
||||
:preamble nil
|
||||
:preamble-case-fold nil))))
|
||||
|
||||
(describe "(not)"
|
||||
(it "simple query"
|
||||
(expect (org-ql--query-preamble '(not (regexp "a")))
|
||||
:to-equal (list :query '(not (regexp "a"))
|
||||
:preamble nil
|
||||
:preamble-case-fold nil))))
|
||||
|
||||
(describe "(clocked)"
|
||||
(it "without arguments"
|
||||
(expect (org-ql--query-preamble '(clocked))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue