jiri/org-ql
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Refactor/Add: agenda->view/search, view-sidebar

Browse source 
Squash-merging branch wip/refactor-org-ql-agenda.

Squashed commit of the following:

commit 60d73b071830ab8f0355687a1d325a4791eeb29b
Author: Adam Porter <adam@alphapapa.net>
Date:   Wed Sep 18 04:30:55 2019 -0500

    WIP: Tidy

commit 36f65638cdb585553c0f90ef48b3908700461014
Author: Adam Porter <adam@alphapapa.net>
Date:   Wed Sep 18 04:24:45 2019 -0500

    WIP: Tidy

commit f7bae3ac8c250c4e42b79157656603da91185574
Author: Adam Porter <adam@alphapapa.net>
Date:   Wed Sep 18 04:10:36 2019 -0500

    WIP: Tidy

commit 8791b0de3404cfff9e110969b8aa30c753319335
Author: Adam Porter <adam@alphapapa.net>
Date:   Wed Sep 18 04:05:18 2019 -0500

    WIP: Remove unnecessary defvars

commit 0dd8d259a31e279ad76188640f6731f8fdf0ae88
Author: Adam Porter <adam@alphapapa.net>
Date:   Wed Sep 18 04:03:27 2019 -0500

    WIP: (org-ql-search.el) Require org-super-agenda

commit 76981fbcd3eba7d1b8d096c094a013953c2d3333
Author: Adam Porter <adam@alphapapa.net>
Date:   Mon Sep 16 19:49:07 2019 -0500

    WIP: More refactoring

commit a3e58f4d44aa804bfd9ff537aca53647dd068329
Author: Adam Porter <adam@alphapapa.net>
Date:   Mon Sep 16 19:21:20 2019 -0500

    WIP: View list sidebar

commit 56f27cd87f0ef246d31328e4c7a41ad2a1c57553
Author: Adam Porter <adam@alphapapa.net>
Date:   Sat Aug 31 22:25:09 2019 -0500

    WIP: Split org-ql-agenda into org-ql-view and org-ql-search
This commit is contained in:
Adam Porter 2019-09-22 20:59:00 -05:00
parent 8f2a02264f
commit 5864c28cdb
7 changed files with 828 additions and 716 deletions
Download patch file Download diff file Expand all files Collapse all files

31
README.org
View file

@ -118,23 +118,13 @@ Installing with [[https://framagit.org/steckerhalter/quelpa][Quelpa]] is easy:
* Usage * Usage
The functionality provided may be grouped by: These commands and functions are included:
+ *Interactive commands:* ~org-ql-search~, ~org-ql-view~, =org-ql-sparse-tree=, =helm-org-ql=.
+ *Non-interactive functions and macros:*
- ~org-ql~ (macro)
- ~org-ql-select~ (function)
- ~org-ql-query~ (function)
- ~org-ql-agenda~ (macro)
- ~org-ql-block~ (agenda function)
Alternatively, they may be grouped by:
+ *Showing an agenda-like view:* + *Showing an agenda-like view:*
- ~org-ql-search~ (command) - ~org-ql-search~ (command)
- ~org-ql-view~ (command) - ~org-ql-view~ (command)
- ~org-ql-block~ (agenda function) - =org-ql-view-sidebar= (command)
- ~org-ql-agenda~ (macro) - ~org-ql-block~ (agenda block function)
+ *Showing a tree in a buffer:* + *Showing a tree in a buffer:*
- =org-ql-sparse-tree= (command) - =org-ql-sparse-tree= (command)
+ *Showing results with Helm*: + *Showing results with Helm*:
@ -193,6 +183,12 @@ Note also that queries in this command are specially handled so that quotes arou
Choose and display a view stored in ~org-ql-views~. Choose and display a view stored in ~org-ql-views~.
*** org-ql-view-sidebar
Show a sidebar window listing views stored in =org-ql-views= for easy access. In the sidebar, press =RET= or =mouse-1= to show the view at point, and press =c= to customize the view at point.
[[images/org-ql-view-sidebar.gif]]
*** org-ql-view-recent-items *** org-ql-view-recent-items
Show items in ~FILES~ from last ~DAYS~ days with timestamps of ~TYPE~. ~TYPE~ may be ~ts~, ~ts-active~, ~ts-inactive~, ~clocked~, ~closed~, ~deadline~, ~planning~, or ~scheduled~. =FILES= defaults to those returned by the function =org-agenda-files=. Show items in ~FILES~ from last ~DAYS~ days with timestamps of ~TYPE~. ~TYPE~ may be ~ts~, ~ts-active~, ~ts-inactive~, ~clocked~, ~closed~, ~deadline~, ~planning~, or ~scheduled~. =FILES= defaults to those returned by the function =org-agenda-files=.
@ -476,6 +472,7 @@ Expands into a call to ~org-ql-select~ with the same arguments. For convenience
*Added* *Added*
+ Command =helm-org-ql=. + Command =helm-org-ql=.
+ Command =org-ql-sparse-tree=, like =org-sparse-tree= for =org-ql= queries. (Thanks to [[https://github.com/akirak][Akira Komamura]].) + Command =org-ql-sparse-tree=, like =org-sparse-tree= for =org-ql= queries. (Thanks to [[https://github.com/akirak][Akira Komamura]].)
+ Command =org-ql-view-sidebar=.
+ Per-buffer, per-heading tag caching, which increases the speed of tags-related queries by 6-7x. + Per-buffer, per-heading tag caching, which increases the speed of tags-related queries by 6-7x.
+ More tags-related predicates and aliases: + More tags-related predicates and aliases:
- For inherited tags: =tags-inherited=, =inherited-tags=, =tags-i=, =itags=. - For inherited tags: =tags-inherited=, =inherited-tags=, =tags-i=, =itags=.
@ -483,15 +480,23 @@ Expands into a call to ~org-ql-select~ with the same arguments. For convenience
- =tags-all=, =tags&=: Matches all given tags using boolean =AND= (rather than boolean =OR=, which the =tags= predicate uses). - =tags-all=, =tags&=: Matches all given tags using boolean =AND= (rather than boolean =OR=, which the =tags= predicate uses).
+ Variable =org-ql-block-header=, which overrides the default header in =org-ql-block= agenda blocks. + Variable =org-ql-block-header=, which overrides the default header in =org-ql-block= agenda blocks.
+ Predicate =(path)=. + Predicate =(path)=.
+ Option =org-ql-views= may now be customized in a guided, structured way with the customization UI (e.g. =M-x customize-option RET org-ql-views RET=, or press =c= in the =org-ql-view-sidebar= buffer).
*Changed* *Changed*
+ Predicate =heading= now accepts multiple regexps, which are matched with boolean =AND=. + Predicate =heading= now accepts multiple regexps, which are matched with boolean =AND=.
+ Predicate =regexp= now matches its regexp arguments with boolean =AND=. + Predicate =regexp= now matches its regexp arguments with boolean =AND=.
+ Package =org-super-agenda= is now a dependency. This removes the need for awkward code to handle the case where it's not installed, and makes grouping features always available. Of course, the global minor mode =org-super-agenda-mode= is not activated by =org-ql=, so no behavior is changed in Org Agenda or =org-ql=; it only means that commands like =org-ql-search= will always provide grouping when called with the appropriate arguments.
*Removed*
+ Macro =org-ql-agenda=. Instead, use function =org-ql-search=. See also command =org-ql-view=, etc.
*Fixed* *Fixed*
+ Predicate =heading= now matches only against heading text, i.e. not including tags at the end of the line, to-do keyword, etc. + Predicate =heading= now matches only against heading text, i.e. not including tags at the end of the line, to-do keyword, etc.
+ Predicate =todo= now matches case-sensitively, avoiding non-todo-keyword matches (e.g. a heading which begins =Waiting on= will no longer match for a todo keyword =WAITING=). + Predicate =todo= now matches case-sensitively, avoiding non-todo-keyword matches (e.g. a heading which begins =Waiting on= will no longer match for a todo keyword =WAITING=).
*Internal*
+ Refactored code from file =org-ql-agenda.el= into files =org-ql-search.el= and =org-ql-view.el=. Function and variable names have been changed accordingly.
** 0.2.1 ** 0.2.1
*Fixed* *Fixed*

6
helm-org-ql.el
View file

@ -131,16 +131,14 @@ Is transformed into this query:
:sources :sources
;; Expansion of `helm-build-sync-source' macro. ;; Expansion of `helm-build-sync-source' macro.
(helm-make-source name 'helm-source-sync (helm-make-source name 'helm-source-sync
:candidates #'(lambda nil :candidates (lambda nil
(let* ((query (helm-org-ql--input-to-query helm-pattern no-and)) (let* ((query (helm-org-ql--input-to-query helm-pattern no-and))
(window-width (window-width (helm-window)))) (window-width (window-width (helm-window))))
(when query (when query
(with-current-buffer (helm-buffer-get) (with-current-buffer (helm-buffer-get)
(setq helm-org-ql-buffers-files buffers-files)) (setq helm-org-ql-buffers-files buffers-files))
(ignore-errors
;; Ignore errors that might be caused by partially typed queries.
(org-ql-select buffers-files query (org-ql-select buffers-files query
:action (list 'helm-org-ql--heading window-width)))))) :action (list 'helm-org-ql--heading window-width)))))
:match #'identity :match #'identity
:fuzzy-match nil :fuzzy-match nil
:multimatch nil :multimatch nil

BIN
images/org-ql-view-sidebar.gif Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 640 KiB

690
org-ql-agenda.el
View file

@ -1,690 +0,0 @@
;;; org-ql-agenda.el --- Agenda-like view based on org-ql -*- lexical-binding: t; -*-
;; Author: Adam Porter <adam@alphapapa.net>
;; Url: https://github.com/alphapapa/org-ql
;;; Commentary:
;; This library is part of the package `org-ql'; it's not a standalone
;; library. It displays buffers similar to Org Agenda buffers, based
;; on `org-ql' queries.
;;; 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 <https://www.gnu.org/licenses/>.
;;; Code:
(require 'cl-lib)
(require 'map)
(require 'org)
(require 'org-element)
(require 'org-agenda)
(require 'seq)
(require 'rx)
(require 'org-ql)
(require 'dash)
(require 's)
;;;; Compatibility
(defvar org-super-agenda-auto-selector-keywords)
(defvar org-super-agenda-groups)
(defvar org-super-agenda-mode)
(declare-function org-super-agenda--group-items "ext:org-super-agenda")
(when (version< org-version "9.2")
(defalias 'org-get-tags #'org-get-tags-at))
;;;; Faces
(defface org-ql-agenda-due-date
'((t (:slant italic :weight bold)))
"Face for due dates in `org-ql-agenda' views."
:group 'org-ql)
;;;; Variables
(defvar org-ql-agenda-buffer-name "*Org-QL-Agenda*"
"Name of default `org-ql-agenda' buffer.")
(defvar org-ql-view-map
(let ((map (copy-keymap org-agenda-mode-map)))
(define-key map "g" #'org-ql-search-refresh)
(define-key map (kbd "C-x C-s") #'org-ql-search-save)
map)
"Keymap for `org-ql-agenda', `org-ql-search', and `org-ql-views' views.
Based on `org-agenda-mode-map'.")
(defvar org-ql-block-header nil
"A string to override the default header in `org-ql-block' agenda blocks.")
;; For refreshing results buffers.
(defvar org-ql-buffers-files)
(defvar org-ql-query)
(defvar org-ql-sort)
(defvar org-ql-narrow)
(defvar org-ql-super-groups)
(defvar org-ql-title)
;;;; Customization
(defcustom org-ql-views
(list (cons "Agenda-like" (lambda ()
(interactive)
(org-ql-search (org-agenda-files)
'(and (not (done))
(or (habit)
(deadline auto)
(scheduled :to today)
(ts-active :on today)))
:sort '(date priority todo)
:groups (when (boundp org-super-agenda-groups)
org-super-agenda-groups))))
(cons "Recent entries" #'org-ql-view-recent-items)
(cons "Review (to-do keyword without timestamp in past 2 weeks)"
(lambda ()
(interactive)
(org-ql-search (org-agenda-files)
'(and (todo)
(not (ts :from -14)))
:title "Review"
:sort '(date priority todo)
:groups '((:auto-parent t)))))
(cons "Stuck Projects" (lambda ()
(interactive)
(org-ql-search (org-agenda-files)
'(and (todo)
(children)
(not (children (todo "NEXT"))))
:title "Stuck Projects"
:sort '(priority date)))))
"Alist of `org-ql-view' commands.
Each value should be a function that calls,
e.g. `org-ql-search' as desired."
:group 'org-ql
:type '(alist :key-type string
:value-type function))
;;;; Macros
;; TODO: DRY these two macros.
;;;###autoload
(cl-defmacro org-ql-agenda (&rest args)
"Display an agenda-like buffer of entries in FILES that match QUERY.
FILES-OR-QUERY is a sexp that is evaluated to get the list of
buffers and files to scan.
QUERY is an `org-ql' query. The query may be passed as
FILES-OR-QUERY and QUERY may be left nil, in which case the list
of files will automatically be set to the value of calling
`org-agenda-files'.
SORT is passed to `org-ql', which see..
NARROW, when non-nil, means to respect narrowing in buffers.
When nil, buffers are widened before being searched.
BUFFER, when non-nil, is a buffer or buffer name to display the
agenda in, rather than the default.
SUPER-GROUPS is used to bind variable `org-super-agenda-groups',
which see. If t, the existing value of `org-super-agenda-groups'
is used, rather than binding it locally."
(declare (indent defun)
(advertised-calling-convention (files-or-query &optional query &key sort narrow buffer super-groups title) nil))
(cl-macrolet ((set-keyword-args (args)
`(setq sort (plist-get ,args :sort)
narrow (plist-get ,args :narrow)
buffer (plist-get ,args :buffer)
super-groups (plist-get ,args :super-groups)
title (plist-get ,args :title))))
(let ((files '(org-agenda-files))
query sort narrow buffer super-groups title)
;; Parse args manually (so we can leave FILES nil for a default argument).
;; TODO: DRY this and org-ql, I think.
(pcase args
(`(,arg-files ,arg-pred . ,(and rest (guard (keywordp (car rest)))))
;; Files, query, and keyword args (FIXME: Can I combine this and the next one? Does it
;; matter if rest is nil or starts with a keyword?)
(setq files arg-files
query arg-pred)
(set-keyword-args rest))
(`(,arg-pred . ,(and rest (guard (keywordp (car rest)))))
;; Query and keyword args, no files
(setq query arg-pred)
(set-keyword-args rest))
(`(,arg-files ,arg-pred)
;; Files and query, no keywords
(setq files arg-files
query arg-pred))
(`(,arg-pred)
;; Only query
(setq query arg-pred)))
(when (eq super-groups t)
(setq super-groups org-super-agenda-groups))
;; Call --agenda
`(org-ql-agenda--agenda ,files
;; TODO: Probably better to just use eval on org-ql rather than reimplementing parts of it here.
',query
:sort ',sort
:buffer ,buffer
:narrow ,narrow
:super-groups ',super-groups
:title ,title))))
;;;; Commands
;; TODO: This is called `org-ql-search' but it's in org-ql-agenda.el because
;; it uses `org-ql-agenda--agenda'. Maybe this could be better organized.
;;;###autoload
(cl-defun org-ql-search (buffers-files query &key narrow groups sort title)
"Read QUERY and search 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'
- An expression which evaluates to a list of files/buffers
- A space-separated list of file or buffer names
GROUPS: An `org-super-agenda' group set. See variable
`org-super-agenda-groups'.
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'.
TITLE: An optional string displayed in the header."
(declare (indent defun))
(interactive (list (pcase-exhaustive (completing-read "Buffers/Files: "
(list 'buffer 'agenda 'all))
("agenda" (org-agenda-files))
("all" (--select (equal (buffer-local-value 'major-mode it) 'org-mode)
(buffer-list)))
("buffer" (current-buffer))
((and form (guard (rx bos "("))) (-flatten (eval (read form))))
(else (s-split (rx (1+ space)) else)))
(read-minibuffer "Query: ")
:narrow (eq current-prefix-arg '(4))
:groups (pcase (completing-read "Group by: "
(append (list "Don't group"
"Global groups")
(when (bound-and-true-p org-super-agenda-auto-selector-keywords)
(cl-loop for type in org-super-agenda-auto-selector-keywords
collect (substring (symbol-name type) 6)))))
("Global groups" org-super-agenda-groups)
("Don't group" nil)
(property (list (list (intern (concat ":auto-" property))))))
:sort (pcase (completing-read "Sort by: "
(list "Don't sort"
"date"
"deadline"
"priority"
"scheduled"
"todo"))
("Don't sort" nil)
(sort (intern sort)))))
(org-ql-agenda--agenda buffers-files
query
:narrow narrow
:sort sort
:super-groups groups
:title title
:buffer "*Org QL Search*"))
(defun org-ql-search-refresh ()
"Refresh current `org-ql-search' buffer."
(interactive)
(let ((current-line (buffer-substring-no-properties (line-beginning-position) (line-end-position)))
(old-pos (point)))
(org-ql-agenda--agenda org-ql-buffers-files
org-ql-query
:sort org-ql-sort
:narrow org-ql-narrow
:super-groups org-ql-super-groups
:title org-ql-title
:buffer (current-buffer))
(goto-char (point-min))
(or (search-forward current-line nil t)
(goto-char old-pos))
(beginning-of-line)))
(defun org-ql-search-save ()
"Save current `org-ql-search' buffer to `org-ql-views'."
(interactive)
(let* ((name (read-string "Save view as: "))
(buffers-files-sexp (cl-etypecase org-ql-buffers-files
(string org-ql-buffers-files)
(list `(list ,@org-ql-buffers-files))
(null nil)))
(function `(lambda ()
(interactive)
(org-ql-search ,buffers-files-sexp
',org-ql-query
:sort ',org-ql-sort
:narrow ,org-ql-narrow
:groups ',org-ql-super-groups
:title ,name))))
(map-put org-ql-views name function #'equal)
(customize-set-variable 'org-ql-views org-ql-views)
(customize-mark-to-save 'org-ql-views)))
;;;###autoload
(defun org-ql-view (&optional view)
"Choose and display a view stored in `org-ql-views'."
(interactive (list (completing-read "View: " (mapcar #'car org-ql-views))))
(call-interactively (alist-get view org-ql-views nil nil #'string=)))
;;;###autoload
(cl-defun org-ql-view-recent-items
(&key days type
(files (org-agenda-files))
(groups '((:auto-parent t)
(:auto-todo t))))
"Show items in FILES from last DAYS days with timestamps of TYPE.
TYPE may be `ts', `ts-active', `ts-inactive', `clocked', or
`closed'."
(interactive (list :days (read-number "Days: ")
:type (->> '(ts ts-active ts-inactive clocked closed)
(completing-read "Timestamp type: ")
intern)))
;; It doesn't make much sense to use other date-based selectors to
;; look into the past, so to prevent confusion, we won't allow them.
(-let* ((query (pcase-exhaustive type
((or 'ts 'ts-active 'ts-inactive)
;; These predicates look forward by default, so we must invert the number.
`(,type :from ,(- days) :to 0))
((or 'clocked 'closed)
`(,type :from ,days :to 0)))))
(org-ql-search files
query
:title "Recent items"
:sort '(date priority todo)
:groups groups)))
;;;###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'.
;; TODO: Use `helm-org-ql' plain-text query processing.
(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))
(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)))
;;;; Functions
(cl-defun org-ql-agenda--agenda (buffers-files query &key entries strings sort buffer narrow super-groups title)
"FIXME: Docstring"
;; TODO: Rename `entries' to `elements'.
(declare (indent defun))
(when (and super-groups (not org-super-agenda-mode))
(user-error "`org-super-agenda-mode' must be activated to use grouping"))
(when (and entries strings)
(user-error "Only one of ENTRIES or STRINGS may be provided"))
(let* ((org-super-agenda-groups super-groups)
(buffer (cl-etypecase buffer
(string (org-ql-agenda--buffer buffer))
(null (org-ql-agenda--buffer buffer))
(buffer buffer)))
(inhibit-read-only t)
string)
(cond (entries)
(strings (setf string (s-join "\n" strings)))
(query (setf entries (org-ql-select buffers-files
query
:sort sort
:narrow narrow
:action 'element-with-markers)))
(t (user-error "One of QUERY, ENTRIES, or STRINGS must be provided")))
(unless string
(setf string (--> entries
(mapcar #'org-ql-agenda--format-element it)
(cond ((bound-and-true-p org-super-agenda-mode) (org-super-agenda--group-items it))
(t it))
(s-join "\n" it))))
(with-current-buffer buffer
(use-local-map org-ql-view-map)
;; Prepare buffer, saving data for refreshing.
(setq-local org-ql-buffers-files buffers-files)
(setq-local org-ql-query query)
(setq-local org-ql-sort sort)
(setq-local org-ql-narrow narrow)
(setq-local org-ql-super-groups super-groups)
(setq-local org-ql-title title)
(setq-local header-line-format (org-ql-agenda--header-line-format buffers-files query title))
;; Clear buffer, insert entries, etc.
(erase-buffer)
(insert string)
(pop-to-buffer (current-buffer))
(org-agenda-finalize)
(goto-char (point-min)))))
(defun org-ql-agenda-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."
(when-let* ((from (org-agenda-files nil 'ifmode))
(items (org-ql-select from
query :action 'element-with-markers)))
;; Not sure if calling the prepare function is necessary, but let's follow the pattern.
(org-agenda-prepare)
;; TODO: `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-agenda--header-line-format from 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-agenda--format-element)
org-agenda-finalize-entries
insert)
(insert "\n")))
;;;###autoload
(defalias 'org-ql-block 'org-ql-agenda-block)
(defun org-ql-agenda--header-line-format (buffers-files query &optional title)
"Return header-line-format for BUFFERS-FILES and QUERY."
(let* ((title (if title
(concat (propertize "View:" 'face 'org-agenda-structure)
title " ")
""))
(query-formatted (format "%S" query))
(query-formatted (propertize (org-ql-agenda--font-lock-string 'emacs-lisp-mode query-formatted)
'help-echo query-formatted))
(query-width (length query-formatted))
(available-width (max 0 (- (window-width)
(length "In: ")
(length "Query: ")
query-width 4)))
(buffers-files-formatted (format "%S" buffers-files))
(buffers-files-formatted (propertize (->> buffers-files-formatted
(org-ql-agenda--font-lock-string 'emacs-lisp-mode)
(s-truncate available-width))
'help-echo buffers-files-formatted)))
(concat title
(propertize "Query:" 'face 'org-agenda-structure)
query-formatted " "
(propertize "In:" 'face 'org-agenda-structure)
buffers-files-formatted)))
(defun org-ql-agenda--font-lock-string (mode s)
"Return string S font-locked according to MODE."
;; TODO: Is this the proper way to do this? It works, but I feel like there must be a built-in way...
(with-temp-buffer
(delay-mode-hooks
(insert s)
(funcall mode)
(font-lock-ensure)
(buffer-string))))
(defun org-ql-agenda--buffer (&optional name)
"Return Agenda NG buffer, creating it if necessary.
If NAME is non-nil, return buffer by that name instead of using
default buffer."
(with-current-buffer (get-buffer-create (or name org-ql-agenda-buffer-name))
(unless (eq major-mode 'org-agenda-mode)
(org-agenda-mode))
(current-buffer)))
(defun org-ql-agenda--format-relative-date (difference)
;; MAYBE: Make this a `defsubst'.
"Return relative date string for DIFFERENCE.
DIFFERENCE should be an integer number of days, positive for
dates in the past, and negative for dates in the future."
(cond ((> difference 0)
(format "%sd ago" difference))
((< difference 0)
(format "in %sd" (* -1 difference)))
(t "today")))
;;;; Faces/properties
(defun org-ql-agenda--format-element (element)
;; This essentially needs to do what `org-agenda-format-item' does,
;; which is a lot. We are a long way from that, but it's a start.
"Return ELEMENT as a string with text-properties set by its property list.
Its property list should be the second item in the list, as
returned by `org-element-parse-buffer'. If ELEMENT is nil,
return an empty string."
(if (not element)
""
(let* ((properties (cadr element))
;; Remove the :parent property, which so bloats the size of
;; the properties list that it makes it essentially
;; impossible to debug, because Emacs takes approximately
;; forever to show it in the minibuffer or with
;; `describe-text-properties'. TODO: Shouldn't be necessary
;; anymore since we're not parsing the whole buffer.
;; Also, remove ":" from key symbols. TODO: It would be
;; better to avoid this somehow. At least, we should use a
;; function to convert plists to alists, if possible.
(properties (cl-loop for (key val) on properties by #'cddr
for symbol = (intern (cl-subseq (symbol-name key) 1))
unless (member symbol '(parent))
append (list symbol val)))
;; TODO: --add-faces is used to add the :relative-due-date property, but that fact is
;; hidden by doing it through --add-faces (which calls --add-scheduled-face and
;; --add-deadline-face), and doing it in this form that gets the title hides it even more.
;; Adding the relative due date property should probably be done explicitly and separately
;; (which would also make it easier to do it independently of faces, etc).
(title (--> (org-ql-agenda--add-faces element)
(org-element-property :raw-value it)
(org-link-display-format it)))
(todo-keyword (-some--> (org-element-property :todo-keyword element)
(org-ql-agenda--add-todo-face it)))
;; TODO: Figure out whether I should use `org-agenda-use-tag-inheritance' or `org-use-tag-inheritance', etc.
(tag-list (if org-use-tag-inheritance
;; NOTE: Tag inheritance cannot be used here unless markers are added, otherwise
;; we can't go to the item's buffer to look for inherited tags. (Or does
;; `org-element-headline-parser' parse inherited tags too? I forget...)
(if-let ((marker (or (org-element-property :org-hd-marker element)
(org-element-property :org-marker element))))
(with-current-buffer (marker-buffer marker)
;; I wish `org-get-tags' used the correct buffer automatically.
(org-get-tags marker (not org-use-tag-inheritance)))
;; No marker found.
;; MAYBE: Issue some kind of warning when no marker is found, because it's
;; likely a mistake. But we don't want to be annoying in case it's intentional.
(org-element-property :tags element))
(org-element-property :tags element)))
(tag-string (when tag-list
(--> tag-list
(s-join ":" it)
(s-wrap it ":")
(org-add-props it nil 'face 'org-tag))))
;; (category (org-element-property :category element))
(priority-string (-some->> (org-element-property :priority element)
(char-to-string)
(format "[#%s]")
(org-ql-agenda--add-priority-face)))
(habit-property (org-with-point-at (org-element-property :begin element)
(when (org-is-habit-p)
(org-habit-parse-todo))))
(due-string (pcase (org-element-property :relative-due-date element)
('nil "")
(string (format " %s " (org-add-props string nil 'face 'org-ql-agenda-due-date)))))
(string (s-join " " (-non-nil (list todo-keyword priority-string title due-string tag-string)))))
(remove-list-of-text-properties 0 (length string) '(line-prefix) string)
;; Add all the necessary properties and faces to the whole string
(--> string
;; TODO: Use agenda-like format strings.
(concat " " it)
(org-add-props it properties
'todo-state todo-keyword
'tags tag-list
'org-habit-p habit-property)))))
(defun org-ql-agenda--add-faces (element)
"Return ELEMENT with deadline and scheduled faces added."
(->> element
(org-ql-agenda--add-scheduled-face)
(org-ql-agenda--add-deadline-face)))
(defun org-ql-agenda--add-priority-face (string)
"Return STRING with priority face added."
(when (string-match "\\(\\[#\\(.\\)\\]\\)" string)
(let ((face (org-get-priority-face (string-to-char (match-string 2 string)))))
(org-add-props string nil 'face face 'font-lock-fontified t))))
(defun org-ql-agenda--add-scheduled-face (element)
"Add faces to ELEMENT's title for its scheduled status."
;; NOTE: Also adding prefix
(if-let ((scheduled-date (org-element-property :scheduled element)))
(let* ((todo-keyword (org-element-property :todo-keyword element))
(today-day-number (org-today))
;; (current-day-number
;; NOTE: Not currently used, but if we ever implement a more "traditional" agenda that
;; shows perspective of multiple days at once, we'll need this, so I'll leave it for now.
;; ;; NOTE: This is supposed to be the, shall we say,
;; ;; pretend, or perspective, day number that this pass
;; ;; through the agenda is being made for. We need to
;; ;; either set this in the calling function, set it here,
;; ;; or accomplish this in a different way. See
;; ;; `org-agenda-get-scheduled' and where `date' is set in
;; ;; `org-agenda-list'.
;; today-day-number)
(scheduled-day-number (org-time-string-to-absolute
(org-element-timestamp-interpreter scheduled-date 'ignore)))
(difference-days (- today-day-number scheduled-day-number))
(relative-due-date (org-add-props (org-ql-agenda--format-relative-date difference-days) nil
'help-echo (org-element-property :raw-value scheduled-date)))
;; NOTE: Unused for now:
;; (show-all (or (eq org-agenda-repeating-timestamp-show-all t)
;; (member todo-keyword org-agenda-repeating-timestamp-show-all)))
;; NOTE: Unused for now: (sexp-p (string-prefix-p "%%" raw-value))
;; NOTE: Unused for now: (raw-value (org-element-property :raw-value scheduled-date))
;; NOTE: I don't remember what `repeat-day-number' was for, but we aren't using it.
;; But I'll leave it here for now.
;; (repeat-day-number (cond (sexp-p (org-time-string-to-absolute scheduled-date))
;; ((< today-day-number scheduled-day-number) scheduled-day-number)
;; (t (org-time-string-to-absolute
;; raw-value
;; (if show-all
;; current-day-number
;; today-day-number)
;; 'future
;; ;; NOTE: I don't like
;; ;; calling `current-buffer'
;; ;; here. If the element has
;; ;; a marker, we should use
;; ;; that.
;; (current-buffer)
;; (org-element-property :begin element)))))
(face (cond ((member todo-keyword org-done-keywords) 'org-agenda-done)
((= today-day-number scheduled-day-number) 'org-scheduled-today)
((> today-day-number scheduled-day-number) 'org-scheduled-previously)
(t 'org-scheduled)))
(title (--> (org-element-property :raw-value element)
(org-add-props it nil
'face face)))
(properties (--> (cadr element)
(plist-put it :title title)
(plist-put it :relative-due-date relative-due-date))))
(list (car element)
properties))
;; Not scheduled
element))
(defun org-ql-agenda--add-deadline-face (element)
"Add faces to ELEMENT's title for its deadline status.
Also store relative due date as string in `:relative-due-date'
property."
;; FIXME: In my config, doesn't apply orange for approaching deadline the same way the Org Agenda does.
(if-let ((deadline-date (org-element-property :deadline element)))
(let* ((today-day-number (org-today))
(deadline-day-number (org-time-string-to-absolute
(org-element-timestamp-interpreter deadline-date 'ignore)))
(difference-days (- today-day-number deadline-day-number))
(relative-due-date (org-add-props (org-ql-agenda--format-relative-date difference-days) nil
'help-echo (org-element-property :raw-value deadline-date)))
;; NOTE: Unused for now: (todo-keyword (org-element-property :todo-keyword element))
;; NOTE: Unused for now: (done-p (member todo-keyword org-done-keywords))
;; NOTE: Unused for now: (today-p (= today-day-number deadline-day-number))
(deadline-passed-fraction (--> (- deadline-day-number today-day-number)
(float it)
(/ it (max org-deadline-warning-days 1))
(- 1 it)))
(face (org-agenda-deadline-face deadline-passed-fraction))
(title (--> (org-element-property :raw-value element)
(org-add-props it nil
'face face)))
(properties (--> (cadr element)
(plist-put it :title title)
(plist-put it :relative-due-date relative-due-date))))
(list (car element)
properties))
;; No deadline
element))
(defun org-ql-agenda--add-todo-face (keyword)
"Return KEYWORD with TODO face added."
(when-let ((face (org-get-todo-face keyword)))
(org-add-props keyword nil 'face face)))
;;;; Footer
(provide 'org-ql-agenda)
;;; org-ql-agenda.el ends here

191
org-ql-search.el Normal file
View file

@ -0,0 +1,191 @@
;;; org-ql-search.el --- Search commands for org-ql -*- lexical-binding: t; -*-
;; Author: Adam Porter <adam@alphapapa.net>
;; 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 <https://www.gnu.org/licenses/>.
;;; Code:
(require 'cl-lib)
(require 'dash)
(require 'org-super-agenda)
(require 's)
(require 'org-ql)
(require 'org-ql-view)
;;;; 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'.
;; TODO: Use `helm-org-ql' plain-text query processing.
(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))
(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))
"Read QUERY and search 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'
- An expression which evaluates to a list of files/buffers
- A space-separated list of file or buffer names
SUPER-GROUPS: An `org-super-agenda' group set. See variable
`org-super-agenda-groups'.
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'.
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 (pcase-exhaustive (completing-read "Buffers/Files: "
(list 'buffer 'agenda 'all)
nil t)
("agenda" (org-agenda-files))
("all" (--select (equal (buffer-local-value 'major-mode it) 'org-mode)
(buffer-list)))
("buffer" (current-buffer))
((and form (guard (rx bos "("))) (-flatten (eval (read form))))
(else (s-split (rx (1+ space)) else)))
(read-minibuffer "Query: ")
:narrow (eq current-prefix-arg '(4))
:super-groups (when (bound-and-true-p org-super-agenda-auto-selector-keywords)
(pcase (completing-read "Group by: "
(append (list "Don't group"
"Global super-groups")
(cl-loop for type in org-super-agenda-auto-selector-keywords
collect (substring (symbol-name type) 6))))
("Global super-groups" org-super-agenda-groups)
("Don't group" nil)
(property (list (list (intern (concat ":auto-" property)))))))
:sort (pcase (completing-read "Sort by: "
(list "Don't sort"
"date"
"deadline"
"priority"
"scheduled"
"todo"))
("Don't sort" nil)
(sort (intern sort)))))
(let* ((results (org-ql-select buffers-files query
:action 'element-with-markers
:narrow narrow
:sort sort))
(strings (-map #'org-ql-view--format-element results))
(title (or title (format "%S in %S" query buffers-files)))
(buffer (or buffer (format "%s %s*" org-ql-view-buffer-name-prefix title)))
(header (org-ql-view--header-line-format buffers-files query 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 super-groups))
(setf strings (org-super-agenda--group-items strings))))
(org-ql-view--display :buffer buffer :header header
:string (s-join "\n" strings))))
(defun org-ql-search-block (query)
"Insert items for QUERY into current buffer.
QUERY should be an `org-ql' query form. Like other agenda block
commands, it searches files returned by function
`org-agenda-files'. 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. Inserts a newline
after the block."
(when-let* ((from (org-agenda-files nil 'ifmode))
(items (org-ql-select from query
:action 'element-with-markers)))
;; 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 (org-ql-search--header-line-format from query))
(insert (org-add-props (org-ql-view--header-line-format from 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)
;;;; Footer
(provide 'org-ql-search)
;;; org-ql-search.el ends here

608
org-ql-view.el Normal file
View file

@ -0,0 +1,608 @@
;;; org-ql-view.el --- Agenda-like view based on org-ql -*- lexical-binding: t; -*-
;; Author: Adam Porter <adam@alphapapa.net>
;; Url: https://github.com/alphapapa/org-ql
;;; Commentary:
;; This library is part of the package `org-ql'; it's not a standalone
;; library. It displays strings in buffers similar to Org Agenda
;; 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 <https://www.gnu.org/licenses/>.
;;; Code:
;;;; Requirements
(require 'cl-lib)
(require 'map)
(require 'org)
(require 'org-element)
(require 'org-agenda)
(require 'seq)
(require 'rx)
(require 'subr-x)
(require 'org-ql)
(require 'dash)
(require 's)
(require 'org-super-agenda)
(require 'ov)
;;;; Compatibility
(when (version< org-version "9.2")
(defalias 'org-get-tags #'org-get-tags-at))
;;;; Faces
(defface org-ql-view-due-date
'((t (:slant italic :weight bold)))
"Face for due dates in `org-ql-view' views."
:group 'org-ql)
;;;; Variables
(defvar org-ql-view-buffer-name-prefix "*Org QL View:"
"Prefix for names of `org-ql-view' buffers.")
(defvar org-ql-view-buffer nil
"Optionally set the target buffer for `org-ql-view' commands.
Includes `org-ql-search'. Helpful when passing a buffer argument
down a chain of function calls would be awkward.")
(defvar org-ql-view-map
(let ((map (copy-keymap org-agenda-mode-map)))
(define-key map "g" #'org-ql-view-refresh)
(define-key map (kbd "C-x C-s") #'org-ql-view-save)
map)
"Keymap for `org-ql-view', `org-ql-search', and `org-ql-views' views.
Based on `org-agenda-mode-map'.")
(defvar org-ql-view-list-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "RET") #'org-ql-view-switch)
(define-key map [mouse-1] #'org-ql-view-switch)
(define-key map "c" #'org-ql-view-customize)
map)
"Keymap for `org-ql-view' view list buffer.")
;; For refreshing results buffers.
(defvar-local org-ql-view-buffers-files nil)
(defvar-local org-ql-view-query nil)
(defvar-local org-ql-view-sort nil)
(defvar-local org-ql-view-narrow nil)
(defvar-local org-ql-view-super-groups nil)
(defvar-local org-ql-view-title nil)
;;;; Customization
(defgroup org-ql-view nil
"Options for `org-ql-view'."
:group 'org-ql)
(defcustom org-ql-view-display-buffer-action nil
"Action argument passed through `pop-to-buffer' to `display-buffer', which see."
:type '(cons function alist))
(defcustom org-ql-view-list-side 'right
"Which side to show the view list on."
:type '(choice (const :tag "Left" left)
(const :tag "Right" right)))
(defcustom org-ql-view-no-other-window nil
"Whether `other-window' commands should cycle through the `org-ql-views' sidebar window.
See info node `(elisp)Cyclic Window Ordering'."
:type 'boolean)
(defcustom org-ql-view-list-slot 0
"Side-window slot for Org QL Views list buffer."
:type 'integer)
(defcustom org-ql-views
(list (cons "Recent entries" #'org-ql-view-recent-items)
(cons "Review (to-do keyword without timestamp in past 2 weeks)"
(list :buffers-files #'org-agenda-files
:query '(and (todo)
(not (ts :from -14)))
:title "Review"
:sort '(date priority todo)
:super-groups '((:auto-parent t))))
(cons "Stuck Projects" (list :buffers-files #'org-agenda-files
:query '(and (todo)
(children)
(not (children (todo "NEXT"))))
:title "Stuck Projects"
:sort '(priority date)
:super-groups 'org-super-agenda-groups))
(cons "Agenda-like" (list :buffers-files #'org-agenda-files
:query '(and (not (done))
(or (habit)
(deadline auto)
(scheduled :to today)
(ts-active :on today)))
:sort '(date priority todo)
:super-groups 'org-super-agenda-groups
:title "Agenda-like"))
(cons "Today" (list :buffers-files #'org-agenda-files
:query '(ts-active :on today)
:title "Today"
:super-groups 'org-super-agenda-groups
:sort '(priority)))
(cons "This week" (lambda ()
"Show items with an active timestamp during this calendar week."
(interactive)
(let* ((beg-of-week (ts-adjust 'day (- (ts-dow (ts-now))) (ts-now)))
(end-of-week (ts-adjust 'day (- 6 (ts-dow (ts-now))) (ts-now))))
(org-ql-search (org-agenda-files)
`(ts-active :from ,beg-of-week
:to ,end-of-week)
:title "This week"
:super-groups 'org-super-agenda-groups
:sort '(priority)))))
(cons "Next week" (lambda ()
"Show items with an active timestamp during the next calendar week."
(interactive)
(let* ((ts (ts-adjust 'day 7 (ts-now)))
(beg-of-week (ts-adjust 'day (- (ts-dow (ts-now))) ts))
(end-of-week (ts-adjust 'day (- 6 (ts-dow (ts-now))) ts)))
(org-ql-search (org-agenda-files)
`(ts-active :from ,beg-of-week
:to ,end-of-week)
:title "Next week"
:super-groups 'org-super-agenda-groups
:sort '(priority))))))
"Alist of `org-ql-view' commands."
:type
'(alist
:key-type (string :tag "Name")
:value-type
(choice (function :tag "Function which calls `org-ql-search'")
(plist :tag "Org QL Search"
:options (((const :tag "Buffers/files" :buffers-files)
(choice (function-item :tag "Org Agenda Files" org-agenda-files)
(repeat :tag "Buffer or file names" string)
(function :tag "Function which returns a list of buffers and/or files" list)))
((const :tag "Query" :query) (sexp :tag "org-ql query sexp"))
((const :tag "Search title" :title) string)
((const :tag "Sort-by" :sort) (repeat
(choice (const date)
(const deadline)
(const scheduled)
(const todo)
(const priority)
(const random)
(function :tag "Custom comparator"))))
((const :tag "Group-by" :super-groups)
(choice (variable-item :tag "Default org-super-agenda groups" org-super-agenda-groups)
(sexp :tag "org-super-agenda grouping expression")
(variable :tag "Variable holding org-super-agenda grouping expression"))))))))
;;;; Commands
;;;###autoload
(defun org-ql-view (&optional name)
"Choose and display the `org-ql-views' view NAME.
Interactively, prompt for NAME."
(interactive (list (completing-read "View: " (mapcar #'car org-ql-views))))
(let* ((view (alist-get name org-ql-views nil nil #'string=))
(window (--find (string-prefix-p org-ql-view-buffer-name-prefix (buffer-name (window-buffer it)))
(window-list)))
(org-ql-view-display-buffer-action (when (and window (not org-ql-view-display-buffer-action))
(cons #'display-buffer-same-window nil))))
(when window
(select-window window))
(cl-typecase view
(function (call-interactively view))
(list (-let* (((&plist :buffers-files :query :sort :narrow :super-groups :title) view)
(buffers-files (cl-typecase buffers-files
(function (funcall buffers-files))
(list buffers-files)))
(super-groups (cl-typecase super-groups
(symbol (symbol-value super-groups))
(list super-groups))))
(org-ql-search buffers-files query
:super-groups super-groups :narrow narrow :sort sort :title title
:buffer org-ql-view-buffer))))))
;;;###autoload
(cl-defun org-ql-view-recent-items
(&key num-days (type 'ts)
(files (org-agenda-files))
(groups '((:auto-parent t)
(:auto-todo t))))
"Show items in FILES from last NUM-DAYS days with timestamps of TYPE.
TYPE may be `ts', `ts-active', `ts-inactive', `clocked', or
`closed'."
(interactive (list :num-days (read-number "Days: ")
:type (->> '(ts ts-active ts-inactive clocked closed)
(completing-read "Timestamp type: ")
intern)))
;; It doesn't make much sense to use other date-based selectors to
;; look into the past, so to prevent confusion, we won't allow them.
(-let* ((query (pcase-exhaustive type
((or 'ts 'ts-active 'ts-inactive)
`(,type :from ,(- num-days) :to 0))
((or 'clocked 'closed)
`(,type :from ,(- num-days) :to 0)))))
(org-ql-search files query
:title "Recent items"
:sort '(date priority todo)
:super-groups groups)))
;;;###autoload
(cl-defun org-ql-view-sidebar (&key (slot org-ql-view-list-slot))
"Show `org-ql-view' view list sidebar."
;; TODO: Update sidebar when `org-ql-views' changes.
(interactive)
(select-window
(or (get-buffer-window (org-ql-view--list-buffer))
(display-buffer-in-side-window
(org-ql-view--list-buffer)
(list (cons 'side org-ql-view-list-side)
(cons 'slot slot)
(cons 'window-parameters (list (cons 'no-delete-other-windows t)
(cons 'no-other-window org-ql-view-no-other-window))))))))
(defun org-ql-view-switch ()
"Switch to view at point."
(interactive)
(let ((key (buffer-substring-no-properties (point-at-bol) (point-at-eol))))
(unless (string-empty-p key)
(ov-clear :org-ql-view-selected)
(ov (point-at-bol) (1+ (point-at-eol)) :org-ql-view-selected t
'face '(:weight bold :inherit highlight))
(org-ql-view key))))
(defun org-ql-view-refresh ()
"Refresh current `org-ql-search' buffer."
(interactive)
(let ((current-line (buffer-substring-no-properties (line-beginning-position) (line-end-position)))
(old-pos (point)))
(org-ql-search org-ql-view-buffers-files
org-ql-view-query
:sort org-ql-view-sort
:narrow org-ql-view-narrow
:super-groups org-ql-view-super-groups
:title org-ql-view-title
:buffer (current-buffer))
(goto-char (point-min))
(or (when (search-forward current-line nil t)
(beginning-of-line))
(goto-char old-pos))))
(defun org-ql-view-save ()
"Save current `org-ql-search' buffer to `org-ql-views'."
(interactive)
(let* ((name (read-string "Save view as: "))
(plist (list :buffers-files org-ql-view-buffers-files
:query org-ql-view-query
:sort org-ql-view-sort
:narrow org-ql-view-narrow
:super-groups org-ql-view-super-groups
:title name)))
(map-put org-ql-views name plist #'equal)
(customize-set-variable 'org-ql-views org-ql-views)
(customize-mark-to-save 'org-ql-views)))
(defun org-ql-view-customize ()
"Customize view at point in `org-ql-view-sidebar' buffer."
(interactive)
(let ((key (buffer-substring-no-properties (point-at-bol) (point-at-eol))))
(customize-option 'org-ql-views)
(search-forward (concat "Name: " key))))
;;;; Functions
(defun org-ql-view--list-buffer ()
"Return view list buffer."
(with-current-buffer (get-buffer-create "*Org QL View List*")
(use-local-map org-ql-view-list-map)
(setf buffer-read-only t
mode-line-format nil
header-line-format (propertize " Org QL Views"
'face 'header-line))
(let ((inhibit-read-only t))
(erase-buffer)
(->> org-ql-views
(-map #'car)
(-sort #'string<)
(s-join "\n")
insert))
(current-buffer)))
(cl-defun org-ql-view--display (&key (buffer org-ql-view-buffer) header string)
"Display STRING in `org-ql-view' BUFFER.
BUFFER may be a buffer, or a string naming a buffer, which is
reused if it already exists. `org-ql-view-buffer' is used by
default.
HEADER is a string displayed in the buffer's header line.
The following special variables, if non-nil, are set
buffer-locally to preserve their value in the buffer for
subsequent refreshing of the buffer: `org-ql-view-buffers-files',
`org-ql-view-query', `org-ql-view-sort', `org-ql-view-narrow',
`org-ql-view-super-groups', `org-ql-title.'"
(declare (indent defun))
(let* ((buffer (cl-etypecase buffer
(string (org-ql-view--buffer buffer))
(null (org-ql-view--buffer buffer))
(buffer buffer))))
(with-current-buffer buffer
(use-local-map org-ql-view-map)
;; Prepare buffer, saving data for refreshing.
(cl-loop for symbol in (list 'org-ql-view-buffers-files 'org-ql-view-query
'org-ql-view-sort 'org-ql-view-narrow
'org-ql-view-super-groups 'org-ql-view-title)
do (set (make-local-variable symbol) (symbol-value symbol)))
(setf header-line-format header)
;; Clear buffer, insert entries, etc.
(let ((inhibit-read-only t))
(erase-buffer)
(insert string)
(pop-to-buffer (current-buffer) org-ql-view-display-buffer-action)
(org-agenda-finalize)
(goto-char (point-min))))))
(defun org-ql-view--header-line-format (buffers-files query &optional title)
"Return header-line-format for BUFFERS-FILES and QUERY."
(let* ((title (if title
(concat (propertize "View:" 'face 'org-agenda-structure)
title " ")
""))
(query-formatted (format "%S" query))
(query-formatted (propertize (org-ql-view--font-lock-string 'emacs-lisp-mode query-formatted)
'help-echo query-formatted))
(query-width (length query-formatted))
(available-width (max 0 (- (window-width)
(length "In: ")
(length "Query: ")
query-width 4)))
(buffers-files-formatted (format "%S" buffers-files))
(buffers-files-formatted (propertize (->> buffers-files-formatted
(org-ql-view--font-lock-string 'emacs-lisp-mode)
(s-truncate available-width))
'help-echo buffers-files-formatted)))
(concat title
(propertize "Query:" 'face 'org-agenda-structure)
query-formatted " "
(propertize "In:" 'face 'org-agenda-structure)
buffers-files-formatted)))
(defun org-ql-view--font-lock-string (mode s)
"Return string S font-locked according to MODE."
;; FIXME: Is this the proper way to do this? It works, but I feel like there must be a built-in way...
(with-temp-buffer
(delay-mode-hooks
(insert s)
(funcall mode)
(font-lock-ensure)
(buffer-string))))
(defun org-ql-view--buffer (&optional name)
"Return `org-ql-view' buffer, creating it if necessary.
If NAME is non-nil, return buffer by that name instead of using
default buffer."
(with-current-buffer (get-buffer-create (or name (concat org-ql-view-buffer-name-prefix "*")))
(unless (eq major-mode 'org-agenda-mode)
(org-agenda-mode))
(current-buffer)))
(defun org-ql-view--format-relative-date (difference)
;; MAYBE: Make this a `defsubst'.
"Return relative date string for DIFFERENCE.
DIFFERENCE should be an integer number of days, positive for
dates in the past, and negative for dates in the future."
(cond ((> difference 0)
(format "%sd ago" difference))
((< difference 0)
(format "in %sd" (* -1 difference)))
(t "today")))
;;;; Faces/properties
(defun org-ql-view--format-element (element)
;; This essentially needs to do what `org-agenda-format-item' does,
;; which is a lot. We are a long way from that, but it's a start.
"Return ELEMENT as a string with text-properties set by its property list.
Its property list should be the second item in the list, as
returned by `org-element-parse-buffer'. If ELEMENT is nil,
return an empty string."
(if (not element)
""
(let* ((properties (cadr element))
;; Remove the :parent property, which so bloats the size of
;; the properties list that it makes it essentially
;; impossible to debug, because Emacs takes approximately
;; forever to show it in the minibuffer or with
;; `describe-text-properties'. FIXME: Shouldn't be necessary
;; anymore since we're not parsing the whole buffer.
;; Also, remove ":" from key symbols. FIXME: It would be
;; better to avoid this somehow. At least, we should use a
;; function to convert plists to alists, if possible.
(properties (cl-loop for (key val) on properties by #'cddr
for symbol = (intern (cl-subseq (symbol-name key) 1))
unless (member symbol '(parent))
append (list symbol val)))
;; TODO: --add-faces is used to add the :relative-due-date property, but that fact is
;; hidden by doing it through --add-faces (which calls --add-scheduled-face and
;; --add-deadline-face), and doing it in this form that gets the title hides it even more.
;; Adding the relative due date property should probably be done explicitly and separately
;; (which would also make it easier to do it independently of faces, etc).
(title (--> (org-ql-view--add-faces element)
(org-element-property :raw-value it)
(org-link-display-format it)))
(todo-keyword (-some--> (org-element-property :todo-keyword element)
(org-ql-view--add-todo-face it)))
;; FIXME: Figure out whether I should use `org-agenda-use-tag-inheritance' or `org-use-tag-inheritance', etc.
(tag-list (if org-use-tag-inheritance
;; FIXME: Note that tag inheritance cannot be used here unless markers are
;; added, otherwise we can't go to the item's buffer to look for inherited
;; tags. (Or does `org-element-headline-parser' parse inherited tags too? I
;; forget...)
(if-let ((marker (or (org-element-property :org-hd-marker element)
(org-element-property :org-marker element))))
(with-current-buffer (marker-buffer marker)
;; I wish `org-get-tags' used the correct buffer automatically.
(org-get-tags marker (not org-use-tag-inheritance)))
;; No marker found
(warn "No marker found for item: %s" title)
(org-element-property :tags element))
(org-element-property :tags element)))
(tag-string (when tag-list
(--> tag-list
(s-join ":" it)
(s-wrap it ":")
(org-add-props it nil 'face 'org-tag))))
;; (category (org-element-property :category element))
(priority-string (-some->> (org-element-property :priority element)
(char-to-string)
(format "[#%s]")
(org-ql-view--add-priority-face)))
(habit-property (org-with-point-at (org-element-property :begin element)
(when (org-is-habit-p)
(org-habit-parse-todo))))
(due-string (pcase (org-element-property :relative-due-date element)
('nil "")
(string (format " %s " (org-add-props string nil 'face 'org-ql-view-due-date)))))
(string (s-join " " (-non-nil (list todo-keyword priority-string title due-string tag-string)))))
(remove-list-of-text-properties 0 (length string) '(line-prefix) string)
;; Add all the necessary properties and faces to the whole string
(--> string
;; FIXME: Use proper prefix
(concat " " it)
(org-add-props it properties
'todo-state todo-keyword
'tags tag-list
'org-habit-p habit-property)))))
(defun org-ql-view--add-faces (element)
"Return ELEMENT with deadline and scheduled faces added."
(->> element
(org-ql-view--add-scheduled-face)
(org-ql-view--add-deadline-face)))
(defun org-ql-view--add-priority-face (string)
"Return STRING with priority face added."
(when (string-match "\\(\\[#\\(.\\)\\]\\)" string)
(let ((face (org-get-priority-face (string-to-char (match-string 2 string)))))
(org-add-props string nil 'face face 'font-lock-fontified t))))
(defun org-ql-view--add-scheduled-face (element)
"Add faces to ELEMENT's title for its scheduled status."
;; NOTE: Also adding prefix
(if-let ((scheduled-date (org-element-property :scheduled element)))
(let* ((todo-keyword (org-element-property :todo-keyword element))
(today-day-number (org-today))
;; (current-day-number
;; NOTE: Not currently used, but if we ever implement a more "traditional" agenda that
;; shows perspective of multiple days at once, we'll need this, so I'll leave it for now.
;; ;; FIXME: This is supposed to be the, shall we say,
;; ;; pretend, or perspective, day number that this pass
;; ;; through the agenda is being made for. We need to
;; ;; either set this in the calling function, set it here,
;; ;; or accomplish this in a different way. See
;; ;; `org-agenda-get-scheduled' and where `date' is set in
;; ;; `org-agenda-list'.
;; today-day-number)
(scheduled-day-number (org-time-string-to-absolute
(org-element-timestamp-interpreter scheduled-date 'ignore)))
(difference-days (- today-day-number scheduled-day-number))
(relative-due-date (org-add-props (org-ql-view--format-relative-date difference-days) nil
'help-echo (org-element-property :raw-value scheduled-date)))
;; FIXME: Unused for now:
;; (show-all (or (eq org-agenda-repeating-timestamp-show-all t)
;; (member todo-keyword org-agenda-repeating-timestamp-show-all)))
;; FIXME: Unused for now: (sexp-p (string-prefix-p "%%" raw-value))
;; FIXME: Unused for now: (raw-value (org-element-property :raw-value scheduled-date))
;; FIXME: I don't remember what `repeat-day-number' was for, but we aren't using it.
;; But I'll leave it here for now.
;; (repeat-day-number (cond (sexp-p (org-time-string-to-absolute scheduled-date))
;; ((< today-day-number scheduled-day-number) scheduled-day-number)
;; (t (org-time-string-to-absolute
;; raw-value
;; (if show-all
;; current-day-number
;; today-day-number)
;; 'future
;; ;; FIXME: I don't like
;; ;; calling `current-buffer'
;; ;; here. If the element has
;; ;; a marker, we should use
;; ;; that.
;; (current-buffer)
;; (org-element-property :begin element)))))
(face (cond ((member todo-keyword org-done-keywords) 'org-agenda-done)
((= today-day-number scheduled-day-number) 'org-scheduled-today)
((> today-day-number scheduled-day-number) 'org-scheduled-previously)
(t 'org-scheduled)))
(title (--> (org-element-property :raw-value element)
(org-add-props it nil
'face face)))
(properties (--> (cadr element)
(plist-put it :title title)
(plist-put it :relative-due-date relative-due-date))))
(list (car element)
properties))
;; Not scheduled
element))
(defun org-ql-view--add-deadline-face (element)
"Add faces to ELEMENT's title for its deadline status.
Also store relative due date as string in `:relative-due-date'
property."
;; FIXME: In my config, doesn't apply orange for approaching deadline the same way the Org Agenda does.
(if-let ((deadline-date (org-element-property :deadline element)))
(let* ((today-day-number (org-today))
(deadline-day-number (org-time-string-to-absolute
(org-element-timestamp-interpreter deadline-date 'ignore)))
(difference-days (- today-day-number deadline-day-number))
(relative-due-date (org-add-props (org-ql-view--format-relative-date difference-days) nil
'help-echo (org-element-property :raw-value deadline-date)))
;; FIXME: Unused for now: (todo-keyword (org-element-property :todo-keyword element))
;; FIXME: Unused for now: (done-p (member todo-keyword org-done-keywords))
;; FIXME: Unused for now: (today-p (= today-day-number deadline-day-number))
(deadline-passed-fraction (--> (- deadline-day-number today-day-number)
(float it)
(/ it (max org-deadline-warning-days 1))
(- 1 it)))
(face (org-agenda-deadline-face deadline-passed-fraction))
(title (--> (org-element-property :raw-value element)
(org-add-props it nil
'face face)))
(properties (--> (cadr element)
(plist-put it :title title)
(plist-put it :relative-due-date relative-due-date))))
(list (car element)
properties))
;; No deadline
element))
(defun org-ql-view--add-todo-face (keyword)
"Return KEYWORD with TODO face added."
(when-let ((face (org-get-todo-face keyword)))
(org-add-props keyword nil 'face face)))
;;;; Footer
(provide 'org-ql-view)
;;; org-ql-view.el ends here

6
org-ql.el
View file

@ -3,7 +3,7 @@
;; Author: Adam Porter <adam@alphapapa.net> ;; Author: Adam Porter <adam@alphapapa.net>
;; Url: https://github.com/alphapapa/org-ql ;; Url: https://github.com/alphapapa/org-ql
;; Version: 0.3-pre ;; Version: 0.3-pre
;; Package-Requires: ((emacs "26.1") (dash "2.13") (org "9.0") (s "1.12.0") (ts "0.2")) ;; Package-Requires: ((emacs "26.1") (dash "2.13") (org "9.0") (org-super-agenda "1.2-pre") (ov "1.0.6") (s "1.12.0") (ts "0.2"))
;; Keywords: hypermedia, outlines, Org, agenda ;; Keywords: hypermedia, outlines, Org, agenda
;;; Commentary: ;;; Commentary:
@ -162,7 +162,7 @@ point at the beginning of its heading. It may be:
- `element-with-markers': Equivalent to calling - `element-with-markers': Equivalent to calling
`org-element-headline-parser', with markers added using `org-element-headline-parser', with markers added using
`org-ql--add-markers'. Suitable for formatting with `org-ql--add-markers'. Suitable for formatting with
`org-ql-agenda--format-element', allowing insertion into an Org `org-ql-view--format-element', allowing insertion into an Org
Agenda-like buffer. Agenda-like buffer.
- A sexp, which will be byte-compiled into a lambda function. - A sexp, which will be byte-compiled into a lambda function.
@ -247,7 +247,7 @@ are returned by this function. It may be:
- `element-with-markers': Equivalent to - `element-with-markers': Equivalent to
`org-element-headline-parser', with markers added using `org-element-headline-parser', with markers added using
`org-ql--add-markers'. Suitable for formatting with `org-ql--add-markers'. Suitable for formatting with
`org-ql-agenda--format-element', allowing insertion into an Org `org-ql-view--format-element', allowing insertion into an Org
Agenda-like buffer. Agenda-like buffer.
- A sexp, which will be byte-compiled into a lambda function. - A sexp, which will be byte-compiled into a lambda function.