jiri/org-ql
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge 41821ccc76 into 94f9e6f303

Browse source
This commit is contained in:
yantar92 2021-08-14 05:24:18 +00:00 • committed by GitHub
commit 52c26413f1
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
2 changed files with 199 additions and 59 deletions
Download patch file Download diff file Expand all files Collapse all files

143
org-ql.el
View file

@ -515,7 +515,8 @@ If NARROW is non-nil, buffer will not be widened."
(unless narrow (unless narrow
(widen)) (widen))
(goto-char (point-min)) (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)) (outline-next-heading))
(if (not (org-at-heading-p)) (if (not (org-at-heading-p))
(progn (progn
@ -564,6 +565,7 @@ Returns cons (INHERITED-TAGS . LOCAL-TAGS)."
'org-ql-nil)) 'org-ql-nil))
(inherited-tags (or (when org-use-tag-inheritance (inherited-tags (or (when org-use-tag-inheritance
(save-excursion (save-excursion
(org-with-wide-buffer
(if (org-up-heading-safe) (if (org-up-heading-safe)
;; Return parent heading's tags. ;; Return parent heading's tags.
(-let* (((inherited local) (org-ql--tags-at (point))) (-let* (((inherited local) (org-ql--tags-at (point)))
@ -582,7 +584,7 @@ Returns cons (INHERITED-TAGS . LOCAL-TAGS)."
('nil tags) ('nil tags)
(_ (-difference tags org-tags-exclude-from-inheritance)))) (_ (-difference tags org-tags-exclude-from-inheritance))))
;; Top-level heading: use file tags. ;; Top-level heading: use file tags.
org-file-tags))) org-file-tags))))
'org-ql-nil)) 'org-ql-nil))
(all-tags (list inherited-tags local-tags))) (all-tags (list inherited-tags local-tags)))
;; Check caches again, because they may have been set now. ;; 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'." defined in `org-ql-predicates' by calling `org-ql-defpred'."
(cl-labels ((rec (element) (cl-labels ((rec (element)
(pcase 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)) ((pred stringp) `(regexp ,element))
,@normalizer-patterns ,@normalizer-patterns
;; Any other form: passed through unchanged. ;; Any other form: passed through unchanged.
(_ element)))) (_ element))))
;; Repeat normalization until result doesn't change (limiting to 10 in case of an infinite-loop bug). ;; 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. ;; 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 (-let* (((&plist :preambles) (cdr it)))
(--map (pcase-let* ((`(,pattern ,exp) it)) (--map (pcase-let* ((`(,pattern ,exp) it))
`(,pattern `(,pattern ,exp))
(-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)))
preambles)) preambles))
predicates))))) predicates)))))
(fset 'org-ql--query-preamble (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'." defined in `org-ql-predicates' by calling `org-ql-defpred'."
(pcase org-ql-use-preamble (pcase org-ql-use-preamble
('nil (list :query query :preamble nil)) ('nil (list :query query :preamble nil))
(_ (let ((preamble-case-fold t) (_ (cl-labels ((rec (element)
org-ql-preamble)
(cl-labels ((rec (element)
(or (when org-ql-preamble
;; Only one preamble is allowed
element)
(pcase element (pcase element
(`(or _) element)
,@preamble-patterns ,@preamble-patterns
(_ (list :query element)))))
(`(and . ,rest) (-let* (((&plist :regexp :case-fold :query) (funcall #'rec query)))
(let ((clauses (mapcar #'rec rest))) (setq query (pcase query
`(and ,@(-non-nil clauses)))) ((or `nil
(_ element))))) `(nil)
(setq query (pcase (mapcar #'rec (list query))
((or `(nil)
`((nil)) `((nil))
`((and)) `((and))
`((or))) `((or)))
t) t)
(`(t) t) (`(t) t)
(query (-flatten-n 1 query)))) (_ query)))
(list :query query :preamble org-ql-preamble :preamble-case-fold preamble-case-fold))))))) (list :query query :preamble regexp :preamble-case-fold case-fold)))))))
;; For some reason, byte-compiling the backquoted lambda form directly causes a warning ;; 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 ;; 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. ;; 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. ;; redefinitions until all of the predicates have been defined.
(setf org-ql-defpred-defer t) (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) (org-ql-defpred category (&rest categories)
"Return non-nil if current heading is in one or more of CATEGORIES (a list of strings)." "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)))) :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) (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). "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." If TAGS is nil, return non-nil if heading has any inherited tags."
:normalizers ((`(,predicate-names . ,tags) :normalizers ((`(,predicate-names)
`(tags-inherited ,@tags)) `(tags-inherited))
(`(,predicate-names) (`(,predicate-names . ,tags)
`(tags-inherited))) `(tags-inherited ,@tags)))
:body (cl-macrolet ((tags-p (tags) :body (cl-macrolet ((tags-p (tags)
`(and ,tags `(and ,tags
(not (eq 'org-ql-nil ,tags))))) (not (eq 'org-ql-nil ,tags)))))

75
tests/test-org-ql.el
View file

@ -469,6 +469,11 @@ with keyword arg NOW in PLIST."
(expect (org-ql--normalize-query '(and (todo "TODO") (expect (org-ql--normalize-query '(and (todo "TODO")
(or "string1" "string2"))) (or "string1" "string2")))
:to-equal '(and (todo "TODO") (or (regexp "string1") (regexp "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") (expect (org-ql--normalize-query '(when (todo "TODO")
(or "string1" "string2"))) (or "string1" "string2")))
:to-equal '(when (todo "TODO") (or (regexp "string1") (regexp "string2")))) :to-equal '(when (todo "TODO") (or (regexp "string1") (regexp "string2"))))
@ -517,6 +522,76 @@ with keyword arg NOW in PLIST."
;; TODO: Other predicates. ;; 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)" (describe "(clocked)"
(it "without arguments" (it "without arguments"
(expect (org-ql--query-preamble '(clocked)) (expect (org-ql--query-preamble '(clocked))