Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

[WIP] Implement boolean preambles #204

Open
wants to merge 16 commits into
base: master
Choose a base branch
from
Open

[WIP] Implement boolean preambles #204

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
16 commits
Select commit Hold shift + click to select a range
1b794a5
Implement boolean preambles
yantar92 Apr 5, 2021
e1a464f
Update clauses in boolean preambles
yantar92 Apr 5, 2021
9b30c41
Take clauses from preambles when possible
yantar92 Apr 5, 2021
3e6818d
Bypass narrowing when calculating inherited tags in narrowed buffer
yantar92 Apr 5, 2021
dc6f2d2
Avoid compiler warnings when defining predicate without body
yantar92 Apr 6, 2021
e3f45f3
Use alternative way to suppress warnings
yantar92 Apr 6, 2021
b4ff5cc
Use human-readable recursive function name for normalizers and preambles
yantar92 Apr 6, 2021
3c1550e
Remove unnecessary save-excursion
yantar92 Apr 6, 2021
f05ae55
fixup! Remove unnecessary save-excursion
yantar92 Apr 6, 2021
387594e
Update docstrings
yantar92 Apr 6, 2021
204e2d2
Fix shadowed pcase clause
yantar92 Apr 6, 2021
93a7f5c
Simplify code
yantar92 Apr 14, 2021
60c67b4
Fix preamble for body in when and unless predicates
yantar92 Apr 14, 2021
67618c4
Add tests
yantar92 Apr 17, 2021
567c4c4
Fix test
yantar92 Apr 17, 2021
41821cc
Revert "Use human-readable recursive function name for normalizers an…
yantar92 Aug 14, 2021
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
183 changes: 124 additions & 59 deletions org-ql.el
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -564,25 +565,26 @@ Returns cons (INHERITED-TAGS . LOCAL-TAGS)."
'org-ql-nil))
(inherited-tags (or (when org-use-tag-inheritance
(save-excursion
(if (org-up-heading-safe)
;; Return parent heading's tags.
(-let* (((inherited local) (org-ql--tags-at (point)))
(tags (when (or inherited local)
(cond ((and (listp inherited)
(listp local))
(->> (append inherited local)
-non-nil -uniq))
((listp inherited) inherited)
((listp local) local)))))
(cl-typecase org-use-tag-inheritance
(list (setf tags (-intersection tags org-use-tag-inheritance)))
(string (setf tags (--select (string-match org-use-tag-inheritance it)
tags))))
(pcase org-tags-exclude-from-inheritance
('nil tags)
(_ (-difference tags org-tags-exclude-from-inheritance))))
;; Top-level heading: use file tags.
org-file-tags)))
(org-with-wide-buffer
(if (org-up-heading-safe)
;; Return parent heading's tags.
(-let* (((inherited local) (org-ql--tags-at (point)))
(tags (when (or inherited local)
(cond ((and (listp inherited)
(listp local))
(->> (append inherited local)
-non-nil -uniq))
((listp inherited) inherited)
((listp local) local)))))
(cl-typecase org-use-tag-inheritance
(list (setf tags (-intersection tags org-use-tag-inheritance)))
(string (setf tags (--select (string-match org-use-tag-inheritance it)
tags))))
(pcase org-tags-exclude-from-inheritance
('nil tags)
(_ (-difference tags org-tags-exclude-from-inheritance))))
;; Top-level heading: use 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.
Expand Down Expand Up @@ -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).
Expand All @@ -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
Expand All @@ -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)
(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)
(_ (cl-labels ((rec (element)
(pcase element
,@preamble-patterns
(_ (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.
Expand Down Expand Up @@ -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))))
Expand Down Expand Up @@ -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)))))
Expand Down
75 changes: 75 additions & 0 deletions tests/test-org-ql.el
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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"))))
Expand Down Expand Up @@ -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))
Expand Down