WIP: (org-ql-search) Rename argument

org-ql-search.el

@@ -147,19 +147,20 @@ Runs `org-occur-hook' after making the sparse tree."
       num-results)))
 
 ;;;###autoload
-(cl-defun org-ql-search (buffers-files query &key narrow super-groups sort title
-                                       (buffer org-ql-view-buffer))
+(cl-defun org-ql-search (in query &key narrow super-groups sort title
+                            (buffer org-ql-view-buffer))
   "Search for QUERY with `org-ql'.
 Interactively, prompt for these variables:
 
-BUFFERS-FILES: A list of buffers and/or files to search.
-Interactively, may also be:
+IN: Passed to `org-ql-select', which see.  Interactively, may
+also be:
 
 - `buffer': search the current buffer
 - `all': search all Org buffers
-- `agenda': search buffers returned by the function `org-agenda-files'
+- `agenda': search buffers returned by the function
+  `org-agenda-files'
 - `directory': search Org files in `org-directory'
-- A space-separated list of file or buffer names
+- A space-separated list of file/buffer names or Org heading IDs
 
 QUERY: An `org-ql' query in either sexp or non-sexp form (see
 Info node `(org-ql)Queries').
@@ -168,8 +169,9 @@ SUPER-GROUPS: An `org-super-agenda' group set.  See variable
 `org-super-agenda-groups' and Info node `(org-super-agenda)Group
 selectors'.
 
-NARROW: When non-nil, don't widen buffers before
-searching.  Interactively, with prefix, leave narrowed.
+NARROW: Passed to `org-ql-select', but set automatically when
+called interactively based on the value of BUFFERS-FILES; the
+user should not need to pass this argument.
 
 SORT: One or a list of `org-ql' sorting functions, like `date' or
 `priority' (see Info node `(org-ql)Listing / acting-on results').
@@ -181,12 +183,19 @@ display the results.  By default, the value of
 `org-ql-view-buffer' is used, and a new buffer is created if
 necessary."
   (declare (indent defun))
-  (interactive (list (org-ql-view--complete-buffers-files)
-                     (read-string "Query: " (when org-ql-view-query
-                                              (format "%S" org-ql-view-query)))
-                     :narrow (or org-ql-view-narrow (eq current-prefix-arg '(4)))
-                     :super-groups (org-ql-view--complete-super-groups)
-                     :sort (org-ql-view--complete-sort)))
+  (interactive
+   (let* ((in (org-ql-view--complete-buffers-files))
+          (query (read-string "Query: " (when org-ql-view-query
+                                          (format "%S" org-ql-view-query))))
+          (narrow (if (equal in (current-buffer))
+                      (or org-ql-view-narrow
+                          (when (buffer-narrowed-p)
+                            (setf in (or (org-id-get (point-min))
+                                         (copy-marker (point-min))))))
+                    org-ql-view-narrow)))
+     (list in query :narrow narrow
+           :super-groups (org-ql-view--complete-super-groups)
+           :sort (org-ql-view--complete-sort))))
   ;; NOTE: Using `with-temp-buffer' is a hack to work around the fact that `make-local-variable'
   ;; does not work reliably from inside a `let' form when the target buffer is current on entry
   ;; to or exit from the `let', even though `make-local-variable' is actually done in
@@ -200,16 +209,16 @@ necessary."
                               ;; Parse non-sexp query into sexp query.
                               (org-ql--query-string-to-sexp query)))
                     (list query)))
-           (results (org-ql-select buffers-files query
+           (results (org-ql-select in query
                       :action 'element-with-markers
                       :narrow narrow
                       :sort sort))
            (strings (-map #'org-ql-view--format-element results))
            (buffer (or buffer (format "%s %s*" org-ql-view-buffer-name-prefix (or title query))))
            (header (org-ql-view--header-line-format
-                    :buffers-files buffers-files :query query :title title))
+                    :buffers-files in :query query :title title))
            ;; Bind variables for `org-ql-view--display' to set.
-           (org-ql-view-buffers-files buffers-files)
+           (org-ql-view-buffers-files in)
            (org-ql-view-query query)
            (org-ql-view-sort sort)
            (org-ql-view-narrow narrow)

org-ql-view.el

@@ -480,7 +480,7 @@ If TITLE, prepend it to the header."
     (concat title
             (when query (propertize "Query:" 'face 'transient-argument))
             (when query query-propertized)
-            (when query "  ")
+            (when query " ")
             (when buffers-files
               (propertize "In:" 'face 'transient-argument))
             (when buffers-files-formatted
@@ -1044,38 +1044,60 @@ property."
 
 (declare-function org-ql-search-directories-files "org-ql-search" t)
 
-(defun org-ql-view--contract-buffers-files (buffers-files)
-  "Return BUFFERS-FILES in its \"contracted\" form.
-The contracted form is \"org-agenda-files\" if BUFFERS-FILES
-matches the value of `org-agenda-files' (either the function or
-the variable), \"org-directory\" if it matches the value of
+(defun org-ql-view--contract-buffers-files (in)
+  "Return IN in its \"contracted\" form.
+The contracted form is \"org-agenda-files\" if IN matches the
+value of `org-agenda-files' (either the function or the
+variable), \"org-directory\" if it matches the value of
 `org-ql-search-directories-files', or \"buffer\" if it is the
-current buffer.  Otherwise BUFFERS-FILES is returned unchanged."
+current buffer.  Otherwise IN 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-elt (it)
+                (cl-typecase it
+                  (string (or (expanded it)
+                              (location-of it)
+                              (error "Unknown expansion for %S" it)))
+                  (marker (or (location-of it)
+                              (error "Unknown location for %S" it)))
+                  (otherwise it)))
+              (expanded (filename)
+                (when-let ((expanded (expand-file-name filename))
+                           ((file-readable-p expanded)))
+                  expanded))
+              (location-of (place)
+                (when-let ((marker (cl-etypecase place
+                                     (marker place)
+                                     (string (org-id-find place 'marker))))
+                           (heading (org-link-display-format (org-entry-get marker "ITEM"))))
+                  (setf heading (if (string-empty-p heading)
+                                    place
+                                  (or (org-id-get marker)
+                                      (string-join (org-with-point-at marker
+                                                     (org-get-outline-path t))
+                                                   " › ")))
+                        ;; FIXME: The help-echo gets overridden elsewhere.
+                        heading (propertize heading 'help-echo (format "%s" place)))
+                  (format "\"%s\" in %S"
+                          heading (abbreviate-file-name (buffer-file-name (marker-buffer marker)))))))
     ;; TODO: Test this more exhaustively.
-    (pcase buffers-files
+    (pcase in
       ((pred listp)
-       (pcase (expand-files buffers-files)
+       (pcase (mapcar #'expand-elt in)
          ((pred (seq-set-equal-p (mapcar #'expand-file-name (org-agenda-files))))
           "org-agenda-files")
          ((and (guard (file-exists-p org-directory))
                (pred (seq-set-equal-p (org-ql-search-directories-files
                                        :directories (list org-directory)))))
           "org-directory")
-         (_ buffers-files)))
+         (_ in)))
       ((pred (equal (current-buffer)))
-       "buffer")
+       (buffer-name (current-buffer)))
       ((or 'org-agenda-files '(function org-agenda-files))
        "org-agenda-files")
-      ((and (pred bufferp) (guard (buffer-file-name buffers-files)))
-       (buffer-file-name buffers-files))
-      (_ buffers-files))))
+      ((and (pred bufferp) (guard (buffer-file-name in)))
+       (buffer-file-name in))
+      (_ (expand-elt in)))))
 
 (defun org-ql-view--complete-buffers-files ()
   "Return value for `org-ql-view-buffers-files' using completion."

org-ql.el

@@ -333,11 +333,12 @@ See Info node `(org-ql)Queries'."
                                                     (sxhash-equal (prin1-to-string args))))
 
 ;;;###autoload
-(cl-defun org-ql-select (buffers-or-files query &key action narrow sort)
-  "Return items matching QUERY in BUFFERS-OR-FILES.
+(cl-defun org-ql-select (in query &key action narrow sort)
+  "Return items matching QUERY in IN.
 
-BUFFERS-OR-FILES is a file or buffer, a list of files and/or
-buffers, or a function which returns such a list.
+IN is a buffer, file, or Org entry ID string (i.e. findable with
+`org-id-goto'), or a list of one or more of such items, or a
+function which returns such a list.
 
 QUERY is an `org-ql' query sexp (quoted, since this is a
 function).
@@ -374,23 +375,27 @@ would appear first.  In contrast, `(date reverse priority)' would
 also present items with the highest priority first, but within
 each priority the newest items would appear first."
   (declare (indent defun))
-  (-let* ((buffers (->> (cl-typecase buffers-or-files
+  (-let* ((sources (->> (cl-typecase in
                           (null (list (current-buffer)))
-                          (function (funcall buffers-or-files))
-                          (list buffers-or-files)
-                          (otherwise (list buffers-or-files)))
-                        (--map (cl-etypecase it
-                                 ;; NOTE: This etypecase is essential to opening links safely,
-                                 ;; as it rejects, e.g. lambdas in the buffers-files argument.
-                                 (buffer it)
-                                 (string (or (find-buffer-visiting it)
-                                             (when (file-readable-p it)
-                                               ;; It feels unintuitive that `find-file-noselect' returns
-                                               ;; a buffer if the filename doesn't exist.
-                                               (find-file-noselect it))
-                                             (display-warning 'org-ql-select (format "Can't open file: %s" it) :error)))))
+                          (list in)
+                          (otherwise (list in)))
+                        (--map (pcase-exhaustive it
+                                 ;; NOTE: This exhaustive pcase is essential to opening links
+                                 ;; safely, as it rejects, e.g. lambdas in the IN argument.
+                                 ((cl-type buffer) it)
+                                 ((cl-type marker) it)
+                                 ((and (cl-type string)
+                                       (pred file-readable-p))
+                                  (or (find-buffer-visiting it)
+                                      (when (file-readable-p it)
+                                        (find-file-noselect it))
+                                      (display-warning 'org-ql-select (format "Can't open file: %s" it) :error)))
+                                 ((cl-type string)
+                                  (org-id-find it 'marker))
+                                 ((cl-type function)
+                                  (funcall it))))
                         ;; Ignore special/hidden buffers.
-                        (--remove (string-prefix-p " " (buffer-name it)))))
+                        (--remove (and (bufferp it) (string-prefix-p " " (buffer-name it))))))
           (query (org-ql--normalize-query query))
           ((&plist :query :preamble :preamble-case-fold) (org-ql--query-preamble query))
           (predicate (org-ql--query-predicate query))
@@ -414,6 +419,18 @@ each priority the newest items would appear first."
                          ,action)))
                     (_ (user-error "Invalid action form: %s" action))))
           (org-ql--today (ts-now))
+          (select-in (lambda (it)
+                       (let* ((marker)
+                              (buffer (cl-etypecase it
+                                        (buffer it)
+                                        (marker (marker-buffer (setf marker it))))))
+                         (with-current-buffer buffer
+                           (unless (derived-mode-p 'org-mode)
+                             (display-warning 'org-ql-select (format  "Not an Org buffer: %s" (buffer-name)) :error))
+                           (org-ql--select-cached :query query :preamble preamble
+                                                  :preamble-case-fold preamble-case-fold
+                                                  :predicate predicate :action action
+                                                  :narrow (or marker narrow))))))
           (items (let (orig-fns)
                    (unwind-protect
                        (progn
@@ -424,14 +441,8 @@ each priority the newest items would appear first."
                              (push (list :name name :fn (symbol-function name)) orig-fns)
                              ;; Temporarily set new function definition.
                              (fset name fn)))
-                         ;; Run query on buffers.
-                         (->> buffers
-                              (--map (with-current-buffer it
-                                       (unless (derived-mode-p 'org-mode)
-                                         (display-warning 'org-ql-select (format  "Not an Org buffer: %s" (buffer-name)) :error))
-                                       (org-ql--select-cached :query query :preamble preamble :preamble-case-fold preamble-case-fold
-                                                              :predicate predicate :action action :narrow narrow)))
-                              (-flatten-n 1)))
+                         ;; Collect results.
+                         (-flatten-n 1 (mapcar select-in sources)))
                      (--each orig-fns
                        ;; Restore original function mappings.
                        (-let (((&plist :name :fn) it))
@@ -466,8 +477,7 @@ are returned by this function.  It may be:
 
 - A function symbol.
 
-FROM corresponds to the `org-ql-select' argument BUFFERS-OR-FILES.
-It may be one or a list of file paths and/or buffers.
+FROM corresponds to the `org-ql-select' argument IN, which see.
 
 WHERE corresponds to the `org-ql-select' argument QUERY.  It
 should be an `org-ql' query sexp.
@@ -491,10 +501,12 @@ NARROW corresponds to the `org-ql-select' argument NARROW."
            ;; The key must include the preamble, because some queries are replaced by
            ;; the preamble, leaving a nil query, which would make the key ambiguous.
            (list :query query :preamble preamble :action action :preamble-case-fold preamble-case-fold
-                 (if narrow
-                     ;; Use bounds of narrowed portion of buffer.
-                     (cons (point-min) (point-max))
-                   nil))))
+                 :narrow (pcase-exhaustive narrow
+                           ((cl-type string) narrow)
+                           ((cl-type marker) narrow)
+                           (`t ;; Use bounds of narrowed portion of buffer.
+                            (cons (point-min) (point-max)))
+                           (`nil nil)))))
     (if-let* ((buffer-cache (gethash (current-buffer) org-ql-cache))
               (query-cache (cadr buffer-cache))
               (modified-tick (car buffer-cache))
@@ -529,32 +541,44 @@ PREAMBLE-CASE-FOLD."
   ;; can't be used, so we do it manually (this is same as the equivalent `flet' expansion).
   ;; Mappings are stored in the variable because it allows predicates to be defined with a
   ;; macro, which allows documentation to be easily generated for them.
-  (save-excursion
-    (save-restriction
-      (unless narrow
-        (widen))
-      (goto-char (point-min))
-      (when (org-before-first-heading-p)
-        (outline-next-heading))
-      (if (not (org-at-heading-p))
-          (progn
-            ;; No headings in buffer: return nil.
-            (unless (string-prefix-p " " (buffer-name))
-              ;; Not a special, hidden buffer: show message, because if a user accidentally
-              ;; searches a buffer without headings, he might be confused.
-              (message "org-ql: No headings in buffer: %s" (current-buffer)))
-            nil)
-        ;; Find matching entries.
-        ;; TODO: Bind `case-fold-search' around the preamble loop.
-        (cond (preamble (cl-loop while (let ((case-fold-search preamble-case-fold))
-                                         (re-search-forward preamble nil t))
-                                 do (outline-back-to-heading 'invisible-ok)
-                                 when (funcall predicate)
-                                 collect (funcall action)
-                                 do (outline-next-heading)))
-              (t (cl-loop when (funcall predicate)
-                          collect (funcall action)
-                          while (outline-next-heading))))))))
+  (let (old-restriction)
+    (save-excursion
+      (save-restriction
+        (pcase narrow
+          ((cl-type marker)
+           (switch-to-buffer (marker-buffer narrow)) ;; Can change buffer!
+           (setf old-restriction (if (buffer-narrowed-p)
+                                     (cons (point-min) (point-max))
+                                   t))
+           (goto-char narrow)
+           (org-narrow-to-subtree))
+          (`nil (widen)))
+        (goto-char (point-min))
+        (when (org-before-first-heading-p)
+          (outline-next-heading))
+        (if (not (org-at-heading-p))
+            (progn
+              ;; No headings in buffer: return nil.
+              (unless (string-prefix-p " " (buffer-name))
+                ;; Not a special, hidden buffer: show message, because if a user accidentally
+                ;; searches a buffer without headings, he might be confused.
+                (message "org-ql: No headings in buffer: %s" (current-buffer)))
+              nil)
+          ;; Find matching entries.
+          ;; TODO: Bind `case-fold-search' around the preamble loop.
+          (unwind-protect
+              (cond (preamble (cl-loop while (let ((case-fold-search preamble-case-fold))
+                                               (re-search-forward preamble nil t))
+                                       do (outline-back-to-heading 'invisible-ok)
+                                       when (funcall predicate)
+                                       collect (funcall action)
+                                       do (outline-next-heading)))
+                    (t (cl-loop when (funcall predicate)
+                                collect (funcall action)
+                                while (outline-next-heading))))
+            (pcase old-restriction
+              (`t (widen))
+              (`(,start . ,end) (narrow-to-region start end)))))))))
 
 ;;;;; Helpers