;;; org-ql-search.el --- Search commands for org-ql -*- lexical-binding: t; -*- ;; Author: Adam Porter ;; Url: https://github.com/alphapapa/org-ql ;;; Commentary: ;; This library is part of the package `org-ql'; it's not a standalone ;; library. It implements search commands for Org buffers. ;;; License: ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . ;;; Code: ;;;; Requirements (require 'cl-lib) (require 'dash) (require 'f) (require 'map) (require 'org-super-agenda) (require 's) (require 'org-ql) (require 'org-ql-view) ;;;; Variables (defvar org-ql-block-header nil "An optional string to override the default header in `org-ql-block' agenda blocks.") ;;;; Customization (defgroup org-ql-search nil "Options for `org-ql-search' commands." :group 'org-ql) (defcustom org-ql-search-directories-files-regexp "\.org$" "Regular expression to match Org filenames in `org-directory'. Files matching this regexp will be searched. By default, \".org\" files are matched, but you may also select to include \".org_archive\" files, or use a custom regexp." :type '(radio (const :tag "Normal \".org\" files" :value "\.org$") (const :tag "Also include \".org_archive\" files" "\.org\\(_archive\\)?$") (string :tag "Custom regular expression"))) (defcustom org-ql-search-directories-files-recursive nil "Recurse into subdirectories by default in `org-ql-search-directories-files'. This should probably be disabled by default, because e.g. `org-directory' may include deeply nested directories of non-Org files, such as a \".git\" directory, Org attachments directories, etc, which would make it slow to list the `org-directory' files recursively." :type 'boolean) ;;;; Commands ;;;###autoload (cl-defun org-ql-sparse-tree (query &key keep-previous (buffer (current-buffer))) "Show a sparse tree for QUERY in BUFFER and return number of results. The tree will show the lines where the query matches, and any other context defined in `org-show-context-detail', which see. QUERY is an `org-ql' query sexp (quoted, since this is a function). BUFFER defaults to the current buffer. When KEEP-PREVIOUS is non-nil (interactively, with prefix), the outline is not reset to the overview state before finding matches, which allows stacking calls to this command. Runs `org-occur-hook' after making the sparse tree." ;; Code based on `org-occur'. (interactive (list (read-minibuffer "Query: ") :keep-previous current-prefix-arg)) (with-current-buffer buffer (unless keep-previous ;; We don't do highlighting, because queries aren't regexps, but ;; we remove existing `org-occur' highlights, just in case. (org-remove-occur-highlights nil nil t) (org-overview)) (let ((num-results 0)) ;; FIXME: Accept plain queries as well. (org-ql-select buffer query :action (lambda () (org-show-context 'occur-tree) (cl-incf num-results))) (unless org-sparse-tree-open-archived-trees (org-hide-archived-subtrees (point-min) (point-max))) (run-hooks 'org-occur-hook) (unless (get-buffer-window buffer) (pop-to-buffer buffer)) (message "%d matches" num-results) num-results))) ;;;###autoload (cl-defun org-ql-search (buffers-files 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: - `buffer': search the current buffer - `all': search all Org buffers - `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 QUERY: An `org-ql' query in either sexp or non-sexp form (see Info node `(org-ql)Queries'). 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. SORT: One or a list of `org-ql' sorting functions, like `date' or `priority' (see Info node `(org-ql)Listing / acting-on results'). TITLE: An optional string displayed in the header. BUFFER: Optionally, a buffer or name of a buffer in which to 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))) ;; 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 ;; `org-ql-view--display'. So we do all this within a temp buffer, which works around it. (with-temp-buffer (let* ((query (cl-etypecase query (string (if (or (string-prefix-p "(" query) (string-prefix-p "\"" query)) ;; Read sexp query. (read query) ;; Parse non-sexp query into sexp query. (org-ql--plain-query query))) (list query))) (results (org-ql-select buffers-files 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)) ;; Bind variables for `org-ql-view--display' to set. (org-ql-view-buffers-files buffers-files) (org-ql-view-query query) (org-ql-view-sort sort) (org-ql-view-narrow narrow) (org-ql-view-super-groups super-groups) (org-ql-view-title title)) (when super-groups (let ((org-super-agenda-groups (cl-etypecase super-groups (symbol (symbol-value super-groups)) (list super-groups)))) (setf strings (org-super-agenda--group-items strings)))) (org-ql-view--display :buffer buffer :header header :string (s-join "\n" strings))))) ;;;###autoload (defun org-ql-search-block (query) "Insert items for QUERY into current buffer. QUERY should be an `org-ql' query form. Intended to be used as a user-defined function in `org-agenda-custom-commands'. QUERY corresponds to the `match' item in the custom command form. Like other agenda block commands, it searches files returned by function `org-agenda-files'. Inserts a newline after the block. If `org-ql-block-header' is non-nil, it is used as the header string for the block, otherwise a the header is formed automatically from the query." (let (narrow-p old-beg old-end) (when-let* ((from (pcase org-agenda-overriding-restriction ('nil (org-agenda-files nil 'ifmode)) ('file (get 'org-agenda-files 'org-restrict)) ('subtree (prog1 org-agenda-restrict (with-current-buffer org-agenda-restrict ;; Narrow the buffer; remember to widen it later. (setf old-beg (point-min) old-end (point-max) narrow-p t) (narrow-to-region org-agenda-restrict-begin org-agenda-restrict-end)))))) (items (org-ql-select from query :action 'element-with-markers :narrow narrow-p))) (when narrow-p ;; Restore buffer's previous restrictions. (with-current-buffer from (narrow-to-region old-beg old-end))) ;; Not sure if calling the prepare function is necessary, but let's follow the pattern. (org-agenda-prepare) ;; FIXME: `org-agenda--insert-overriding-header' is from an Org version newer than ;; I'm using. Should probably declare it as a minimum Org version after upgrading. ;; (org-agenda--insert-overriding-header (or org-ql-block-header (org-ql-agenda--header-line-format from query))) (insert (org-add-props (or org-ql-block-header (org-ql-view--header-line-format :buffers-files from :query query)) nil 'face 'org-agenda-structure) "\n") ;; Calling `org-agenda-finalize' should be unnecessary, because in a "series" agenda, ;; `org-agenda-multi' is bound non-nil, in which case `org-agenda-finalize' does nothing. ;; But we do call `org-agenda-finalize-entries', which allows `org-super-agenda' to work. (->> items (-map #'org-ql-view--format-element) org-agenda-finalize-entries insert) (insert "\n")))) ;;;###autoload (defalias 'org-ql-block 'org-ql-search-block) ;;;; Dynamic blocks ;; This section implements support for Org dynamic blocks. See Info node `(org)Dynamic blocks'. (require 'org-table) (cl-defun org-dblock-write:org-ql (params) "Insert content for org-ql dynamic block at point according to PARAMS. Valid parameters include: :query An Org QL query expression in either sexp or non-sexp form. :columns A list of columns, including `heading', `todo', `property', `priority', `deadline', `scheduled'. Each column may also be specified as a list with the second element being a header string. For example, to abbreviate the priority column: (priority \"P\"). For certain columns, like `property', arguments may be passed by specifying the column type itself as a list. For example, to display a column showing the values of a property named \"milestone\", with the header being abbreviated to \"M\": ((property \"milestone\") \"M\"). :sort One or a list of Org QL sorting methods (see `org-ql-select'). :take Optionally take a number of results from the front (a positive number) or the end (a negative number) of the results. :ts-format Optional format string used to format timestamp-based columns. For example, an org-ql dynamic block header could look like: #+BEGIN: org-ql :query (todo \"UNDERWAY\") :columns (priority todo heading) :sort (priority date) :ts-format \"%Y-%m-%d %H:%M\"" (pcase-let* (((map :query :columns :sort :ts-format :take) params) (query (cl-etypecase query (string (org-ql--plain-query query)) (t query))) (columns (or columns '(heading todo (priority "P")))) ;; MAYBE: Custom column functions. (format-fns ;; NOTE: Backquoting this alist prevents the lambdas from seeing ;; the variable `ts-format', so we use `list' and `cons'. (list (cons 'todo (lambda (element) (org-element-property :todo-keyword element))) (cons 'heading (lambda (element) (org-make-link-string (org-element-property :raw-value element) (org-element-property :raw-value element)))) (cons 'priority (lambda (element) (--when-let (org-element-property :priority element) (char-to-string it)))) (cons 'deadline (lambda (element) (--when-let (org-element-property :deadline element) (ts-format ts-format (ts-parse-org-element it))))) (cons 'scheduled (lambda (element) (--when-let (org-element-property :scheduled element) (ts-format ts-format (ts-parse-org-element it))))) (cons 'property (lambda (element property) (org-element-property (intern (concat ":" (upcase property))) element))))) (elements (org-ql-query :from (current-buffer) :where query :select '(org-element-headline-parser (line-end-position)) :order-by sort))) (when take (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))) "")) " | "))) ;; Table header (insert "| " (string-join (--map (pcase it ((pred symbolp) (capitalize (symbol-name it))) (`(,_ ,name) name)) columns) " | ") " |" "\n") (insert "|- \n") ; Separator hline (dolist (element elements) (insert "| " (format-element element) " |" "\n")) (delete-char -1) (org-table-align)))) ;;;; Functions (cl-defun org-ql-search-directories-files (&key (directories (list org-directory)) (recurse org-ql-search-directories-files-recursive) (regexp org-ql-search-directories-files-regexp)) "Return list of matching files in DIRECTORIES, a list of directory paths. When RECURSE is non-nil, recurse into subdirectories. When REGEXP is non-nil, only return files that match REGEXP." (let ((files (->> directories (--map (f-files it nil recurse)) -flatten))) (if regexp (--select (string-match regexp it) files) files))) ;;;; Footer (provide 'org-ql-search) ;;; org-ql-search.el ends here