diff --git a/org-ql-search.el b/org-ql-search.el index b029544..da1cfb3 100644 --- a/org-ql-search.el +++ b/org-ql-search.el @@ -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))) diff --git a/org-ql-view.el b/org-ql-view.el index 5c3b9a2..84507a4 100644 --- a/org-ql-view.el +++ b/org-ql-view.el @@ -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. diff --git a/org-ql.el b/org-ql.el index adc2bec..cc899f2 100644 --- a/org-ql.el +++ b/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 diff --git a/tests/test-org-ql.el b/tests/test-org-ql.el index 12e8eb0..7bf6a9b 100644 --- a/tests/test-org-ql.el +++ b/tests/test-org-ql.el @@ -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")