Tidy: Indentation
For Emacs 29.1's and with-simulated-input's changes.
This commit is contained in:
Adam Porter
parent
c62ff77cd3
commit
004ed1ee0f
4 changed files with 312 additions and 314 deletions
|
|
@ -341,17 +341,17 @@ this (must be a single line in the Org buffer):
|
|||
(setf elements (cl-etypecase take
|
||||
((and integer (satisfies cl-minusp)) (-take-last (abs take) elements))
|
||||
(integer (-take take elements)))))
|
||||
(cl-labels ((format-element
|
||||
(element) (string-join (cl-loop for column in columns
|
||||
collect (or (pcase-exhaustive column
|
||||
((pred symbolp)
|
||||
(funcall (alist-get column format-fns) element))
|
||||
(`((,column . ,args) ,_header)
|
||||
(apply (alist-get column format-fns) element args))
|
||||
(`(,column ,_header)
|
||||
(funcall (alist-get column format-fns) element)))
|
||||
""))
|
||||
" | ")))
|
||||
(cl-labels ((format-element (element)
|
||||
(string-join (cl-loop for column in columns
|
||||
collect (or (pcase-exhaustive column
|
||||
((pred symbolp)
|
||||
(funcall (alist-get column format-fns) element))
|
||||
(`((,column . ,args) ,_header)
|
||||
(apply (alist-get column format-fns) element args))
|
||||
(`(,column ,_header)
|
||||
(funcall (alist-get column format-fns) element)))
|
||||
""))
|
||||
" | ")))
|
||||
;; Table header
|
||||
(insert "| " (string-join (--map (pcase it
|
||||
((pred symbolp) (capitalize (symbol-name it)))
|
||||
|
|
|
|||
|
|
@ -487,11 +487,11 @@ If TITLE, prepend it to the header."
|
|||
Makes QUERY more readable, e.g. timestamp objects are replaced
|
||||
with human-readable strings."
|
||||
(cl-labels ((rec (form)
|
||||
(cl-typecase form
|
||||
(ts (ts-format form))
|
||||
(cons (cons (rec (car form))
|
||||
(rec (cdr form))))
|
||||
(otherwise form))))
|
||||
(cl-typecase form
|
||||
(ts (ts-format form))
|
||||
(cons (cons (rec (car form))
|
||||
(rec (cdr form))))
|
||||
(otherwise form))))
|
||||
(format "%S" (rec query))))
|
||||
|
||||
(defun org-ql-view--font-lock-string (mode s)
|
||||
|
|
@ -533,14 +533,14 @@ dates in the past, and negative for dates in the future."
|
|||
|
||||
(defun org-ql-view-bookmark-make-record ()
|
||||
"Return a bookmark record for the current Org QL View buffer."
|
||||
(cl-labels ((file-nameize
|
||||
(b-f) (abbreviate-file-name
|
||||
(cl-typecase b-f
|
||||
(string b-f)
|
||||
(buffer (or (buffer-file-name b-f)
|
||||
(when (buffer-base-buffer b-f)
|
||||
(buffer-file-name (buffer-base-buffer b-f)))))
|
||||
(t (user-error "Only file-backed buffers can be bookmarked by Org QL View: %s" b-f))))))
|
||||
(cl-labels ((file-nameize (b-f)
|
||||
(abbreviate-file-name
|
||||
(cl-typecase b-f
|
||||
(string b-f)
|
||||
(buffer (or (buffer-file-name b-f)
|
||||
(when (buffer-base-buffer b-f)
|
||||
(buffer-file-name (buffer-base-buffer b-f)))))
|
||||
(t (user-error "Only file-backed buffers can be bookmarked by Org QL View: %s" b-f))))))
|
||||
(-let* ((plist (org-ql-view--plist (current-buffer)))
|
||||
((&plist :buffers-files) plist))
|
||||
;; Replace buffers with their filenames, and signal error if any are not file-backed.
|
||||
|
|
@ -655,23 +655,25 @@ When opened, the link searches the buffer it's opened from."
|
|||
(when org-ql-view-query
|
||||
;; Only Org QL View buffers should have `org-ql-view-query' set.
|
||||
(cl-labels ((prompt-for (buffers-files)
|
||||
(pcase-exhaustive
|
||||
(completing-read (format "Make link that searches: ")
|
||||
'("file link is in" "files currently searched")
|
||||
nil t nil nil "file link is in")
|
||||
("file link is in" nil)
|
||||
("files currently searched" buffers-files)))
|
||||
(strings-or-file-buffers-p
|
||||
(thing) (cl-etypecase thing
|
||||
(list (cl-every #'strings-or-file-buffers-p thing))
|
||||
(string thing)
|
||||
(buffer (or (buffer-file-name thing)
|
||||
;; TODO: Should indirect buffers be allowed? Maybe not, since their narrowing isn't preserved.
|
||||
;; On the other hand, it's possible to accidentally make a search view for an indirect buffer
|
||||
;; that's since been widened, and forcing the user to manually change that would be awkward,
|
||||
;; and trying to communicate the problem would be difficult, so maybe it's okay to allow it.
|
||||
(when (buffer-base-buffer thing)
|
||||
(buffer-file-name (buffer-base-buffer thing))))))))
|
||||
(pcase-exhaustive
|
||||
(completing-read (format "Make link that searches: ")
|
||||
'("file link is in" "files currently searched")
|
||||
nil t nil nil "file link is in")
|
||||
("file link is in" nil)
|
||||
("files currently searched" buffers-files)))
|
||||
(strings-or-file-buffers-p (thing)
|
||||
(cl-etypecase thing
|
||||
(list (cl-every #'strings-or-file-buffers-p thing))
|
||||
(string thing)
|
||||
(buffer (or (buffer-file-name thing)
|
||||
;; TODO: Should indirect buffers be allowed? Maybe not, since their
|
||||
;; narrowing isn't preserved. On the other hand, it's possible to
|
||||
;; accidentally make a search view for an indirect buffer that's
|
||||
;; since been widened, and forcing the user to manually change that
|
||||
;; would be awkward, and trying to communicate the problem would be
|
||||
;; difficult, so maybe it's okay to allow it.
|
||||
(when (buffer-base-buffer thing)
|
||||
(buffer-file-name (buffer-base-buffer thing))))))))
|
||||
(unless (strings-or-file-buffers-p org-ql-view-buffers-files)
|
||||
(user-error "%s" "Views that search non-file-backed buffers can't be linked to"))
|
||||
(let* ((query-string (--if-let (org-ql--query-sexp-to-string org-ql-view-query)
|
||||
|
|
@ -1048,11 +1050,11 @@ the variable), \"org-directory\" if it matches the value of
|
|||
current buffer. Otherwise BUFFERS-FILES is returned unchanged."
|
||||
;; Used in `org-ql-view--complete-buffers-files' and
|
||||
;; `org-ql-view--header-line-format'.
|
||||
(cl-labels ((expand-files
|
||||
(list) (--map (cl-typecase it
|
||||
(string (expand-file-name it))
|
||||
(otherwise it))
|
||||
list)))
|
||||
(cl-labels ((expand-files (list)
|
||||
(--map (cl-typecase it
|
||||
(string (expand-file-name it))
|
||||
(otherwise it))
|
||||
list)))
|
||||
;; TODO: Test this more exhaustively.
|
||||
(pcase buffers-files
|
||||
((pred listp)
|
||||
|
|
@ -1074,10 +1076,10 @@ current buffer. Otherwise BUFFERS-FILES is returned unchanged."
|
|||
|
||||
(defun org-ql-view--complete-buffers-files ()
|
||||
"Return value for `org-ql-view-buffers-files' using completion."
|
||||
(cl-labels ((initial-input
|
||||
() (when org-ql-view-buffers-files
|
||||
(org-ql-view--contract-buffers-files
|
||||
org-ql-view-buffers-files))))
|
||||
(cl-labels ((initial-input ()
|
||||
(when org-ql-view-buffers-files
|
||||
(org-ql-view--contract-buffers-files
|
||||
org-ql-view-buffers-files))))
|
||||
(if (and org-ql-view-buffers-files
|
||||
(bufferp org-ql-view-buffers-files))
|
||||
;; Buffers can't be input by name, so if the default value is a buffer, just use it.
|
||||
|
|
|
|||
403
org-ql.el
403
org-ql.el
|
|
@ -755,38 +755,38 @@ be coalesced."
|
|||
;; can't be coalesced with it since they don't specify the same
|
||||
;; language. That could be fixed, but it's probably not worth it.
|
||||
(cl-labels ((rec (sexp)
|
||||
(pcase sexp
|
||||
(`(,(and boolean (or 'or 'not)) . ,sexps)
|
||||
`(,boolean ,@(mapcar #'rec sexps)))
|
||||
(`(and . ,sexps)
|
||||
(anded sexps))
|
||||
(_ sexp)))
|
||||
(pcase sexp
|
||||
(`(,(and boolean (or 'or 'not)) . ,sexps)
|
||||
`(,boolean ,@(mapcar #'rec sexps)))
|
||||
(`(and . ,sexps)
|
||||
(anded sexps))
|
||||
(_ sexp)))
|
||||
(anded (sexps)
|
||||
(let (anded-predicates new-sexp)
|
||||
(dolist (sexp sexps)
|
||||
(pcase sexp
|
||||
(`(,(or 'or 'not) . ,_)
|
||||
(push (rec sexp) new-sexp))
|
||||
(`(,predicate . ,args)
|
||||
(pcase-exhaustive (plist-get (alist-get predicate org-ql-predicates) :coalesce)
|
||||
(`nil (push sexp new-sexp))
|
||||
(`t (setf (alist-get predicate anded-predicates)
|
||||
(append (alist-get predicate anded-predicates) args)))
|
||||
((and fn (pred functionp))
|
||||
(if-let (new-args (funcall fn (alist-get predicate anded-predicates) args))
|
||||
(setf (alist-get predicate anded-predicates) new-args)
|
||||
(push sexp new-sexp)))))))
|
||||
(delq nil `(and ,@(nreverse new-sexp) ,@(nreverse anded-predicates))))))
|
||||
(let (anded-predicates new-sexp)
|
||||
(dolist (sexp sexps)
|
||||
(pcase sexp
|
||||
(`(,(or 'or 'not) . ,_)
|
||||
(push (rec sexp) new-sexp))
|
||||
(`(,predicate . ,args)
|
||||
(pcase-exhaustive (plist-get (alist-get predicate org-ql-predicates) :coalesce)
|
||||
(`nil (push sexp new-sexp))
|
||||
(`t (setf (alist-get predicate anded-predicates)
|
||||
(append (alist-get predicate anded-predicates) args)))
|
||||
((and fn (pred functionp))
|
||||
(if-let (new-args (funcall fn (alist-get predicate anded-predicates) args))
|
||||
(setf (alist-get predicate anded-predicates) new-args)
|
||||
(push sexp new-sexp)))))))
|
||||
(delq nil `(and ,@(nreverse new-sexp) ,@(nreverse anded-predicates))))))
|
||||
(rec query)))
|
||||
|
||||
(defun org-ql--sanity-check-form (form)
|
||||
"Signal error if any forms in FORM do not have preconditions met.
|
||||
Or, when possible, fix the problem."
|
||||
(cl-flet ((check (symbol)
|
||||
(pcase symbol
|
||||
('done (unless org-done-keywords
|
||||
;; NOTE: This check needs to be done from within the Org buffer being checked.
|
||||
(error "Variable `org-done-keywords' is nil. Are you running this from an Org buffer?"))))))
|
||||
(pcase symbol
|
||||
('done (unless org-done-keywords
|
||||
;; NOTE: This check needs to be done from within the Org buffer being checked.
|
||||
(error "Variable `org-done-keywords' is nil. Are you running this from an Org buffer?"))))))
|
||||
(cl-loop for elem in form
|
||||
if (consp elem)
|
||||
do (progn
|
||||
|
|
@ -808,28 +808,27 @@ respectively."
|
|||
(and "\\" (0+ "\\\\") (any "[]"))
|
||||
(and (1+ "\\") (not (any "[]")))))))
|
||||
(cl-labels
|
||||
((no-desc
|
||||
(match) (rx-to-string `(seq (or bol (1+ blank))
|
||||
"[[" ,link-target-part (regexp ,match) ,link-target-part
|
||||
"]]")))
|
||||
(match-both
|
||||
(description target)
|
||||
(rx-to-string `(seq (or bol (1+ blank))
|
||||
"[[" ,link-target-part (regexp ,target) ,link-target-part
|
||||
"][" (*? anything) (regexp ,description) (*? anything)
|
||||
"]]")))
|
||||
((no-desc (match)
|
||||
(rx-to-string `(seq (or bol (1+ blank))
|
||||
"[[" ,link-target-part (regexp ,match) ,link-target-part
|
||||
"]]")))
|
||||
(match-both (description target)
|
||||
(rx-to-string `(seq (or bol (1+ blank))
|
||||
"[[" ,link-target-part (regexp ,target) ,link-target-part
|
||||
"][" (*? anything) (regexp ,description) (*? anything)
|
||||
"]]")))
|
||||
;; Note that these actually allow empty descriptions
|
||||
;; or targets, depending on what they are matching.
|
||||
(match-desc
|
||||
(match) (rx-to-string `(seq (or bol (1+ blank))
|
||||
"[[" ,link-target-part
|
||||
"][" (*? anything) (regexp ,match) (*? anything)
|
||||
"]]")))
|
||||
(match-target
|
||||
(match) (rx-to-string `(seq (or bol (1+ blank))
|
||||
"[[" ,link-target-part (regexp ,match) ,link-target-part
|
||||
"][" (*? anything)
|
||||
"]]"))))
|
||||
(match-desc (match)
|
||||
(rx-to-string `(seq (or bol (1+ blank))
|
||||
"[[" ,link-target-part
|
||||
"][" (*? anything) (regexp ,match) (*? anything)
|
||||
"]]")))
|
||||
(match-target (match)
|
||||
(rx-to-string `(seq (or bol (1+ blank))
|
||||
"[[" ,link-target-part (regexp ,match) ,link-target-part
|
||||
"][" (*? anything)
|
||||
"]]"))))
|
||||
(cond (description-or-target
|
||||
(rx-to-string `(or (regexp ,(no-desc description-or-target))
|
||||
(regexp ,(match-desc description-or-target))
|
||||
|
|
@ -884,48 +883,48 @@ Arguments STRING, POS, FILL, and LEVEL are according to
|
|||
;; NOTE: The pcases check for both t/nil symbols and strings, because the
|
||||
;; string queries always return keyword arguments' values as strings.
|
||||
(cl-macrolet ((clocked (&key from to on)
|
||||
`(org-ql--predicate-clocked :from ,from :to ,to))
|
||||
`(org-ql--predicate-clocked :from ,from :to ,to))
|
||||
(closed (&key from to on (with-time 'not-found))
|
||||
`(org-ql--predicate-closed :from ,from :to ,to))
|
||||
`(org-ql--predicate-closed :from ,from :to ,to))
|
||||
(deadline (&key from to on (with-time 'not-found))
|
||||
`(org-ql--predicate-deadline
|
||||
:from ,from :to ,to :with-time ',with-time
|
||||
:regexp ,(pcase-exhaustive with-time
|
||||
((or 't "t") org-ql-regexp-deadline-with-time)
|
||||
((or 'nil "nil") org-ql-regexp-deadline-without-time)
|
||||
('not-found org-ql-regexp-deadline))))
|
||||
`(org-ql--predicate-deadline
|
||||
:from ,from :to ,to :with-time ',with-time
|
||||
:regexp ,(pcase-exhaustive with-time
|
||||
((or 't "t") org-ql-regexp-deadline-with-time)
|
||||
((or 'nil "nil") org-ql-regexp-deadline-without-time)
|
||||
('not-found org-ql-regexp-deadline))))
|
||||
(planning (&key from to on (with-time 'not-found))
|
||||
`(org-ql--predicate-planning
|
||||
:from ,from :to ,to :with-time ',with-time
|
||||
:regexp ,(pcase-exhaustive with-time
|
||||
((or 't "t") org-ql-regexp-planning-with-time)
|
||||
((or 'nil "nil") org-ql-regexp-planning-without-time)
|
||||
('not-found org-ql-regexp-planning))))
|
||||
`(org-ql--predicate-planning
|
||||
:from ,from :to ,to :with-time ',with-time
|
||||
:regexp ,(pcase-exhaustive with-time
|
||||
((or 't "t") org-ql-regexp-planning-with-time)
|
||||
((or 'nil "nil") org-ql-regexp-planning-without-time)
|
||||
('not-found org-ql-regexp-planning))))
|
||||
(scheduled (&key from to on (with-time 'not-found))
|
||||
`(org-ql--predicate-scheduled
|
||||
:from ,from :to ,to :with-time ',with-time
|
||||
:regexp ,(pcase-exhaustive with-time
|
||||
((or 't "t") org-ql-regexp-scheduled-with-time)
|
||||
((or 'nil "nil") org-ql-regexp-scheduled-without-time)
|
||||
('not-found org-ql-regexp-scheduled))))
|
||||
`(org-ql--predicate-scheduled
|
||||
:from ,from :to ,to :with-time ',with-time
|
||||
:regexp ,(pcase-exhaustive with-time
|
||||
((or 't "t") org-ql-regexp-scheduled-with-time)
|
||||
((or 'nil "nil") org-ql-regexp-scheduled-without-time)
|
||||
('not-found org-ql-regexp-scheduled))))
|
||||
(ts (&key from to on (type 'both) (with-time 'not-found))
|
||||
;; NOTE: The TYPE argument is elided from the arguments actually passed to the predicate, being converted to the REGEXP argument.
|
||||
;; MAYBE: Move the :regexp handling out of this macrolet and into the normalizer.
|
||||
`(org-ql--predicate-ts
|
||||
:from ,from :to ,to :with-time ',with-time
|
||||
:regexp ,(pcase type
|
||||
((or 'nil 'both) (pcase-exhaustive with-time
|
||||
((or 't "t") org-ql-regexp-ts-both-with-time)
|
||||
((or 'nil "nil") org-ql-regexp-ts-both-without-time)
|
||||
('not-found org-ql-regexp-ts-both)))
|
||||
('active (pcase-exhaustive with-time
|
||||
((or 't "t") org-ql-regexp-ts-active-with-time)
|
||||
((or 'nil "nil") org-ql-regexp-ts-active-without-time)
|
||||
('not-found org-ql-regexp-ts-active)))
|
||||
('inactive (pcase-exhaustive with-time
|
||||
((or 't "t") org-ql-regexp-ts-inactive-with-time)
|
||||
((or 'nil "nil") org-ql-regexp-ts-inactive-without-time)
|
||||
('not-found org-ql-regexp-ts-inactive)))))))
|
||||
;; NOTE: The TYPE argument is elided from the arguments actually passed to the predicate, being converted to the REGEXP argument.
|
||||
;; MAYBE: Move the :regexp handling out of this macrolet and into the normalizer.
|
||||
`(org-ql--predicate-ts
|
||||
:from ,from :to ,to :with-time ',with-time
|
||||
:regexp ,(pcase type
|
||||
((or 'nil 'both) (pcase-exhaustive with-time
|
||||
((or 't "t") org-ql-regexp-ts-both-with-time)
|
||||
((or 'nil "nil") org-ql-regexp-ts-both-without-time)
|
||||
('not-found org-ql-regexp-ts-both)))
|
||||
('active (pcase-exhaustive with-time
|
||||
((or 't "t") org-ql-regexp-ts-active-with-time)
|
||||
((or 'nil "nil") org-ql-regexp-ts-active-without-time)
|
||||
('not-found org-ql-regexp-ts-active)))
|
||||
('inactive (pcase-exhaustive with-time
|
||||
((or 't "t") org-ql-regexp-ts-inactive-with-time)
|
||||
((or 'nil "nil") org-ql-regexp-ts-inactive-without-time)
|
||||
('not-found org-ql-regexp-ts-inactive)))))))
|
||||
,query)))))
|
||||
|
||||
;;;;; String query parsing
|
||||
|
|
@ -1042,21 +1041,21 @@ This function is defined by calling
|
|||
`org-ql--define-normalize-query-fn', which uses normalizer forms
|
||||
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) `(,org-ql-default-predicate ,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) `(,org-ql-default-predicate ,element))
|
||||
|
||||
,@normalizer-patterns
|
||||
,@normalizer-patterns
|
||||
|
||||
;; Any other form: passed through unchanged.
|
||||
(_ element))))
|
||||
;; Any other form: passed through unchanged.
|
||||
(_ element))))
|
||||
;; Repeat normalization until result doesn't change (limiting to 10 in case of an infinite-loop bug).
|
||||
(cl-loop with limit = 10 and count = 0
|
||||
for new-query = (rec query)
|
||||
|
|
@ -1109,18 +1108,18 @@ defined in `org-ql-predicates' by calling `org-ql-defpred'."
|
|||
(_ (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)
|
||||
(or (when org-ql-preamble
|
||||
;; Only one preamble is allowed
|
||||
element)
|
||||
(pcase element
|
||||
(`(or _) element)
|
||||
|
||||
,@preamble-patterns
|
||||
,@preamble-patterns
|
||||
|
||||
(`(and . ,rest)
|
||||
(let ((clauses (mapcar #'rec rest)))
|
||||
`(and ,@(-non-nil clauses))))
|
||||
(_ element)))))
|
||||
(`(and . ,rest)
|
||||
(let ((clauses (mapcar #'rec rest)))
|
||||
`(and ,@(-non-nil clauses))))
|
||||
(_ element)))))
|
||||
(setq query (pcase (mapcar #'rec (list query))
|
||||
((or `(nil)
|
||||
`((nil))
|
||||
|
|
@ -1984,8 +1983,8 @@ language. Matching is done case-insensitively."
|
|||
Tests both inherited and local tags."
|
||||
;; MAYBE: -all versions for inherited and local.
|
||||
:body (cl-macrolet ((tags-p (tags)
|
||||
`(and ,tags
|
||||
(not (eq 'org-ql-nil ,tags)))))
|
||||
`(and ,tags
|
||||
(not (eq 'org-ql-nil ,tags)))))
|
||||
(-let* (((inherited local) (org-ql--tags-at (point))))
|
||||
(cl-typecase tags
|
||||
(null (or (tags-p inherited)
|
||||
|
|
@ -2010,8 +2009,8 @@ If TAGS is nil, return non-nil if heading has any inherited tags."
|
|||
:normalizers ((`(,predicate-names . ,tags)
|
||||
`(tags-inherited ,@tags)))
|
||||
:body (cl-macrolet ((tags-p (tags)
|
||||
`(and ,tags
|
||||
(not (eq 'org-ql-nil ,tags)))))
|
||||
`(and ,tags
|
||||
(not (eq 'org-ql-nil ,tags)))))
|
||||
(-let* (((inherited _) (org-ql--tags-at (point))))
|
||||
(cl-typecase tags
|
||||
(null (tags-p inherited))
|
||||
|
|
@ -2031,8 +2030,8 @@ If TAGS is nil, return non-nil if heading has any local tags."
|
|||
t)
|
||||
:query t)))
|
||||
:body (cl-macrolet ((tags-p (tags)
|
||||
`(and ,tags
|
||||
(not (eq 'org-ql-nil ,tags)))))
|
||||
`(and ,tags
|
||||
(not (eq 'org-ql-nil ,tags)))))
|
||||
(-let* (((_ local) (org-ql--tags-at (point))))
|
||||
(cl-typecase tags
|
||||
(null (tags-p local))
|
||||
|
|
@ -2045,8 +2044,8 @@ Tests both inherited and local tags."
|
|||
:normalizers ((`(,predicate-names . ,regexps)
|
||||
`(tags-regexp ,@regexps)))
|
||||
:body (cl-macrolet ((tags-p (tags)
|
||||
`(and ,tags
|
||||
(not (eq 'org-ql-nil ,tags)))))
|
||||
`(and ,tags
|
||||
(not (eq 'org-ql-nil ,tags)))))
|
||||
(-let* (((inherited local) (org-ql--tags-at (point))))
|
||||
(cl-typecase regexps
|
||||
(null (or (tags-p inherited)
|
||||
|
|
@ -2394,12 +2393,12 @@ any planning prefix); it defaults to 0 (i.e. the whole regexp)."
|
|||
|
||||
:body
|
||||
(cl-macrolet ((next-timestamp ()
|
||||
`(when (re-search-forward regexp limit t)
|
||||
(ts-parse-org (match-string match-group))))
|
||||
`(when (re-search-forward regexp limit t)
|
||||
(ts-parse-org (match-string match-group))))
|
||||
(test-timestamps (pred-form)
|
||||
`(cl-loop for next-ts = (next-timestamp)
|
||||
while next-ts
|
||||
thereis ,pred-form)))
|
||||
`(cl-loop for next-ts = (next-timestamp)
|
||||
while next-ts
|
||||
thereis ,pred-form)))
|
||||
(save-excursion
|
||||
(cond ((not (or from to)) (re-search-forward regexp limit t))
|
||||
((and from to) (test-timestamps (ts-in from to next-ts)))
|
||||
|
|
@ -2425,27 +2424,27 @@ PREDICATES is a list of one or more sorting methods, including:
|
|||
`deadline', `scheduled', `closed' and `priority'."
|
||||
;; MAYBE: Use macrolet instead of flet.
|
||||
(cl-flet* ((sorter (symbol)
|
||||
(pcase symbol
|
||||
((or 'deadline 'scheduled 'closed)
|
||||
(apply-partially #'org-ql--date-type< (intern (concat ":" (symbol-name symbol)))))
|
||||
;; TODO: Rename `date' to `planning'. `date' should be something else.
|
||||
('date #'org-ql--date<)
|
||||
('priority #'org-ql--priority<)
|
||||
('random (lambda (&rest _ignore)
|
||||
(= 0 (random 2))))
|
||||
;; NOTE: reverse and todo are handled below.
|
||||
;; TODO: Add more.
|
||||
(_ (user-error "Invalid sorting predicate: %s" symbol))))
|
||||
(pcase symbol
|
||||
((or 'deadline 'scheduled 'closed)
|
||||
(apply-partially #'org-ql--date-type< (intern (concat ":" (symbol-name symbol)))))
|
||||
;; TODO: Rename `date' to `planning'. `date' should be something else.
|
||||
('date #'org-ql--date<)
|
||||
('priority #'org-ql--priority<)
|
||||
('random (lambda (&rest _ignore)
|
||||
(= 0 (random 2))))
|
||||
;; NOTE: reverse and todo are handled below.
|
||||
;; TODO: Add more.
|
||||
(_ (user-error "Invalid sorting predicate: %s" symbol))))
|
||||
(sort-by-todo-keyword (items)
|
||||
(let* ((grouped-items (--group-by (when-let (keyword (org-element-property :todo-keyword it))
|
||||
(substring-no-properties keyword))
|
||||
items))
|
||||
(sorted-groups (cl-sort grouped-items #'<
|
||||
:key (lambda (keyword)
|
||||
(or (cl-position (car keyword) org-todo-keywords-1 :test #'string=)
|
||||
;; Put at end of list if not found
|
||||
(1+ (length org-todo-keywords-1)))))))
|
||||
(-flatten-n 1 (-map #'cdr sorted-groups)))))
|
||||
(let* ((grouped-items (--group-by (when-let (keyword (org-element-property :todo-keyword it))
|
||||
(substring-no-properties keyword))
|
||||
items))
|
||||
(sorted-groups (cl-sort grouped-items #'<
|
||||
:key (lambda (keyword)
|
||||
(or (cl-position (car keyword) org-todo-keywords-1 :test #'string=)
|
||||
;; Put at end of list if not found
|
||||
(1+ (length org-todo-keywords-1)))))))
|
||||
(-flatten-n 1 (-map #'cdr sorted-groups)))))
|
||||
(dolist (pred predicates)
|
||||
(setq items (pcase pred
|
||||
;; NOTE: Using `reverse' instead of `nreverse' because my gut
|
||||
|
|
@ -2470,16 +2469,16 @@ A and B are Org headline elements. TYPE should be a symbol like
|
|||
"Return non-nil if A's deadline or scheduled property is earlier than B's.
|
||||
Deadline is considered before scheduled."
|
||||
(cl-macrolet ((ts (item)
|
||||
`(or (org-element-property :deadline ,item)
|
||||
(org-element-property :scheduled ,item))))
|
||||
`(or (org-element-property :deadline ,item)
|
||||
(org-element-property :scheduled ,item))))
|
||||
(org-ql--org-timestamp-element< (ts a) (ts b))))
|
||||
|
||||
(defun org-ql--org-timestamp-element< (a b)
|
||||
"Return non-nil if A's date element is earlier than B's.
|
||||
A and B are Org timestamp elements."
|
||||
(cl-macrolet ((ts (ts)
|
||||
`(when ,ts
|
||||
(org-timestamp-format ,ts "%s"))))
|
||||
`(when ,ts
|
||||
(org-timestamp-format ,ts "%s"))))
|
||||
(let* ((a-ts (ts a))
|
||||
(b-ts (ts b)))
|
||||
(cond ((and a-ts b-ts)
|
||||
|
|
@ -2491,7 +2490,7 @@ A and B are Org timestamp elements."
|
|||
"Return non-nil if A's priority is higher than B's.
|
||||
A and B are Org headline elements."
|
||||
(cl-macrolet ((priority (item)
|
||||
`(org-element-property :priority ,item)))
|
||||
`(org-element-property :priority ,item)))
|
||||
;; NOTE: Priorities are numbers in Org elements. This might differ from the priority selector logic.
|
||||
(let ((a-priority (priority a))
|
||||
(b-priority (priority b)))
|
||||
|
|
@ -2519,66 +2518,66 @@ element should be a regexp string."
|
|||
If QUERY can't be converted to a string, return nil."
|
||||
;; This started out pretty simple...but at least it's not just one long function, right?
|
||||
(cl-labels ((complex-p (query)
|
||||
(or (contains-p 'or query)
|
||||
(contains-p 'ancestors query)
|
||||
(contains-p 'children query)
|
||||
(contains-p 'descendants query)
|
||||
(contains-p 'parent query)))
|
||||
(or (contains-p 'or query)
|
||||
(contains-p 'ancestors query)
|
||||
(contains-p 'children query)
|
||||
(contains-p 'descendants query)
|
||||
(contains-p 'parent query)))
|
||||
(contains-p (symbol list)
|
||||
(cl-loop for element in list
|
||||
thereis (or (eq symbol element)
|
||||
(and (listp element)
|
||||
(contains-p symbol element)))))
|
||||
(format-args
|
||||
(args) (let (non-paired paired next-keyword)
|
||||
(cl-loop for arg in args
|
||||
do (cond (next-keyword (push (cons next-keyword arg) paired)
|
||||
(setf next-keyword nil))
|
||||
((keywordp arg) (setf next-keyword (substring (symbol-name arg) 1)))
|
||||
(t (push arg non-paired))))
|
||||
(string-join (append (mapcar #'format-atom non-paired)
|
||||
(nreverse (--map (format "%s=%s" (car it) (cdr it))
|
||||
paired)))
|
||||
",")))
|
||||
(format-atom
|
||||
(atom) (cl-typecase atom
|
||||
(string (if (string-match (rx space) atom)
|
||||
(format "%S" atom)
|
||||
(format "%s" atom)))
|
||||
(t (format "%s" atom))))
|
||||
(format-form
|
||||
(form) (pcase form
|
||||
(`(not . (,rest)) (concat "!" (format-form rest)))
|
||||
(`(priority . ,_) (format-priority form))
|
||||
;; FIXME: Convert (src) queries to non-sexp form...someday...
|
||||
(`(src . ,_) (user-error "Converting (src ...) queries to non-sexp form is not implemented"))
|
||||
(_ (pcase-let* ((`(,pred . ,args) form)
|
||||
(args-string (pcase args
|
||||
('() "")
|
||||
((guard (= 1 (length args))) (format "%s" (car args)))
|
||||
(_ (format-args args)))))
|
||||
(format "%s:%s" pred args-string)))))
|
||||
(format-and
|
||||
(form) (pcase-let* ((`(and . ,rest) form))
|
||||
(string-join (mapcar #'format-form rest) " ")))
|
||||
(format-priority
|
||||
(form) (pcase-let* ((`(priority . ,rest) form)
|
||||
(args (pcase rest
|
||||
(`(,(and comparator (or '< '<= '> '>= '=)) ,letter)
|
||||
(priority-letters comparator letter))
|
||||
(_ rest))))
|
||||
(concat "priority:" (string-join args ","))))
|
||||
(priority-letters
|
||||
(comparator letter) (let* ((char (string-to-char (upcase (symbol-name letter))))
|
||||
(numeric-priorities '(?A ?B ?C))
|
||||
;; NOTE: The comparator inversion is intentional.
|
||||
(others (pcase comparator
|
||||
('< (--select (> it char) numeric-priorities))
|
||||
('<= (--select (>= it char) numeric-priorities))
|
||||
('> (--select (< it char) numeric-priorities))
|
||||
('>= (--select (<= it char) numeric-priorities))
|
||||
('= (--select (= it char) numeric-priorities)))))
|
||||
(mapcar #'char-to-string others))))
|
||||
(cl-loop for element in list
|
||||
thereis (or (eq symbol element)
|
||||
(and (listp element)
|
||||
(contains-p symbol element)))))
|
||||
(format-args (args)
|
||||
(let (non-paired paired next-keyword)
|
||||
(cl-loop for arg in args
|
||||
do (cond (next-keyword (push (cons next-keyword arg) paired)
|
||||
(setf next-keyword nil))
|
||||
((keywordp arg) (setf next-keyword (substring (symbol-name arg) 1)))
|
||||
(t (push arg non-paired))))
|
||||
(string-join (append (mapcar #'format-atom non-paired)
|
||||
(nreverse (--map (format "%s=%s" (car it) (cdr it))
|
||||
paired)))
|
||||
",")))
|
||||
(format-atom (atom)
|
||||
(cl-typecase atom
|
||||
(string (if (string-match (rx space) atom)
|
||||
(format "%S" atom)
|
||||
(format "%s" atom)))
|
||||
(t (format "%s" atom))))
|
||||
(format-form (form)
|
||||
(pcase form
|
||||
(`(not . (,rest)) (concat "!" (format-form rest)))
|
||||
(`(priority . ,_) (format-priority form))
|
||||
;; FIXME: Convert (src) queries to non-sexp form...someday...
|
||||
(`(src . ,_) (user-error "Converting (src ...) queries to non-sexp form is not implemented"))
|
||||
(_ (pcase-let* ((`(,pred . ,args) form)
|
||||
(args-string (pcase args
|
||||
('() "")
|
||||
((guard (= 1 (length args))) (format "%s" (car args)))
|
||||
(_ (format-args args)))))
|
||||
(format "%s:%s" pred args-string)))))
|
||||
(format-and (form)
|
||||
(pcase-let* ((`(and . ,rest) form))
|
||||
(string-join (mapcar #'format-form rest) " ")))
|
||||
(format-priority (form)
|
||||
(pcase-let* ((`(priority . ,rest) form)
|
||||
(args (pcase rest
|
||||
(`(,(and comparator (or '< '<= '> '>= '=)) ,letter)
|
||||
(priority-letters comparator letter))
|
||||
(_ rest))))
|
||||
(concat "priority:" (string-join args ","))))
|
||||
(priority-letters (comparator letter)
|
||||
(let* ((char (string-to-char (upcase (symbol-name letter))))
|
||||
(numeric-priorities '(?A ?B ?C))
|
||||
;; NOTE: The comparator inversion is intentional.
|
||||
(others (pcase comparator
|
||||
('< (--select (> it char) numeric-priorities))
|
||||
('<= (--select (>= it char) numeric-priorities))
|
||||
('> (--select (< it char) numeric-priorities))
|
||||
('>= (--select (<= it char) numeric-priorities))
|
||||
('= (--select (= it char) numeric-priorities)))))
|
||||
(mapcar #'char-to-string others))))
|
||||
;; FIXME: Error out for ts structs passed to `ts' predicate (very unlikely to be linked to).
|
||||
(unless (complex-p query)
|
||||
(pcase query
|
||||
|
|
|
|||
|
|
@ -1844,14 +1844,14 @@ with keyword arg NOW in PLIST."
|
|||
;; have a chance to be gathered. So we make a test buffer and run the test in that, with a test heading.
|
||||
|
||||
(let ((test-buffer (get-buffer-create "*test-org-ql*")))
|
||||
(cl-flet ((open-link
|
||||
(link) (with-current-buffer test-buffer
|
||||
(erase-buffer)
|
||||
(org-mode)
|
||||
(insert "* TODO Test heading \n\n")
|
||||
(insert link)
|
||||
(backward-char 1)
|
||||
(call-interactively #'org-open-at-point))))
|
||||
(cl-flet ((open-link (link)
|
||||
(with-current-buffer test-buffer
|
||||
(erase-buffer)
|
||||
(org-mode)
|
||||
(insert "* TODO Test heading \n\n")
|
||||
(insert link)
|
||||
(backward-char 1)
|
||||
(call-interactively #'org-open-at-point))))
|
||||
|
||||
(describe "buffers-files parameter"
|
||||
:var ((quoted-lambda-link "[[org-ql-search:todo:?buffers-files%3D%28lambda%20nil%20%28error%20%22UNSAFE%22%29%29]]")
|
||||
|
|
@ -2006,16 +2006,15 @@ with keyword arg NOW in PLIST."
|
|||
(when-let ((buffer (find-file-noselect filename 'nowarn)))
|
||||
(kill-buffer buffer))))
|
||||
|
||||
(cl-flet ((var-after-bookmark-set-and-jump
|
||||
(var buffers-files query &key sort super-groups)
|
||||
(org-ql-search buffers-files query
|
||||
:super-groups super-groups
|
||||
:sort sort :title title :buffer view-buffer)
|
||||
(set-buffer view-buffer)
|
||||
(bookmark-set title)
|
||||
(kill-buffer)
|
||||
(bookmark-jump title)
|
||||
(buffer-local-value var (get-buffer (concat "*Org QL View: " title "*")))))
|
||||
(cl-flet ((var-after-bookmark-set-and-jump (var buffers-files query &key sort super-groups)
|
||||
(org-ql-search buffers-files query
|
||||
:super-groups super-groups
|
||||
:sort sort :title title :buffer view-buffer)
|
||||
(set-buffer view-buffer)
|
||||
(bookmark-set title)
|
||||
(kill-buffer)
|
||||
(bookmark-jump title)
|
||||
(buffer-local-value var (get-buffer (concat "*Org QL View: " title "*")))))
|
||||
|
||||
(describe "Grouping"
|
||||
:var ((query '(and (todo "TODO") (regexp "heading")))
|
||||
|
|
@ -2069,18 +2068,18 @@ with keyword arg NOW in PLIST."
|
|||
(describe "Dynamic blocks"
|
||||
(describe "warn about sexp queries"
|
||||
|
||||
(cl-flet ((test-dblock
|
||||
(&optional input) (with-current-buffer (get-buffer-create "*TEST DBLOCK*")
|
||||
(erase-buffer)
|
||||
(org-mode)
|
||||
(insert "* TODO Heading 1\n\n"
|
||||
"#+BEGIN: org-ql :query (or (todo) (regexp \"Heading\")) :columns (todo)\n"
|
||||
"#+END:")
|
||||
(goto-char (point-min))
|
||||
(forward-line 2)
|
||||
(with-simulated-input input
|
||||
(org-dblock-update))
|
||||
(kill-buffer))))
|
||||
(cl-flet ((test-dblock (&optional input)
|
||||
(with-current-buffer (get-buffer-create "*TEST DBLOCK*")
|
||||
(erase-buffer)
|
||||
(org-mode)
|
||||
(insert "* TODO Heading 1\n\n"
|
||||
"#+BEGIN: org-ql :query (or (todo) (regexp \"Heading\")) :columns (todo)\n"
|
||||
"#+END:")
|
||||
(goto-char (point-min))
|
||||
(forward-line 2)
|
||||
(with-simulated-input input
|
||||
(org-dblock-update))
|
||||
(kill-buffer))))
|
||||
|
||||
(it "when org-ql-ask-unsafe-queries is non-nil"
|
||||
;; TODO: Should the query be converted to string form if possible and only warn if not?
|
||||
|
|
@ -2109,39 +2108,37 @@ with keyword arg NOW in PLIST."
|
|||
(insert "* TODO Test heading\n\n")
|
||||
(org-mode)))
|
||||
|
||||
(cl-flet* ((open-link-in
|
||||
(link buffer input)
|
||||
;; Org REDUCED THE NUMBER OF ARGUMENTS TO `org-open-link-from-string'! That BREAKS BACKWARD
|
||||
;; COMPATIBILITY! So I have to make my own function so these tests can work across Org versions!
|
||||
(with-current-buffer buffer
|
||||
(erase-buffer)
|
||||
(org-mode)
|
||||
(insert "* TODO Test heading\n\n")
|
||||
(insert link)
|
||||
(backward-char 1)
|
||||
(with-simulated-input input
|
||||
(org-open-at-point))))
|
||||
(cl-flet* ((open-link-in (link buffer input)
|
||||
;; Org REDUCED THE NUMBER OF ARGUMENTS TO `org-open-link-from-string'! That BREAKS BACKWARD
|
||||
;; COMPATIBILITY! So I have to make my own function so these tests can work across Org versions!
|
||||
(with-current-buffer buffer
|
||||
(erase-buffer)
|
||||
(org-mode)
|
||||
(insert "* TODO Test heading\n\n")
|
||||
(insert link)
|
||||
(backward-char 1)
|
||||
(with-simulated-input input
|
||||
(org-open-at-point))))
|
||||
|
||||
(var-after-link-save-open
|
||||
(var buffers-files query &key sort super-groups
|
||||
(buffer link-buffer) (store-input "RET") open-input)
|
||||
(org-ql-search buffers-files query
|
||||
:super-groups super-groups
|
||||
:sort sort :title title :buffer view-buffer)
|
||||
(with-current-buffer view-buffer
|
||||
(cl-assert (member '("org-ql-search" :follow org-ql-view--link-follow :store org-ql-view--link-store)
|
||||
org-link-parameters)
|
||||
t)
|
||||
(with-simulated-input store-input
|
||||
;; Avoid writing "Stored: ..." to test output.
|
||||
(let ((inhibit-message t))
|
||||
(call-interactively #'org-store-link nil)))
|
||||
(kill-buffer))
|
||||
(cl-assert (and org-stored-links (caar org-stored-links)) t)
|
||||
(open-link-in (caar org-stored-links) buffer open-input)
|
||||
(with-current-buffer (get-buffer (concat "*Org QL View: " title "*"))
|
||||
(prog1 (buffer-local-value var (current-buffer))
|
||||
(kill-buffer)))))
|
||||
(var-after-link-save-open (var buffers-files query &key sort super-groups
|
||||
(buffer link-buffer) (store-input "RET") open-input)
|
||||
(org-ql-search buffers-files query
|
||||
:super-groups super-groups
|
||||
:sort sort :title title :buffer view-buffer)
|
||||
(with-current-buffer view-buffer
|
||||
(cl-assert (member '("org-ql-search" :follow org-ql-view--link-follow :store org-ql-view--link-store)
|
||||
org-link-parameters)
|
||||
t)
|
||||
(with-simulated-input store-input
|
||||
;; Avoid writing "Stored: ..." to test output.
|
||||
(let ((inhibit-message t))
|
||||
(call-interactively #'org-store-link nil)))
|
||||
(kill-buffer))
|
||||
(cl-assert (and org-stored-links (caar org-stored-links)) t)
|
||||
(open-link-in (caar org-stored-links) buffer open-input)
|
||||
(with-current-buffer (get-buffer (concat "*Org QL View: " title "*"))
|
||||
(prog1 (buffer-local-value var (current-buffer))
|
||||
(kill-buffer)))))
|
||||
|
||||
(describe "Queries"
|
||||
:var ((string-query "todo:TODO regexp:heading")
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue