diff --git a/README.org b/README.org index eaa8056..8a6a079 100644 --- a/README.org +++ b/README.org @@ -6,13 +6,15 @@ [[https://melpa.org/#/org-ql][file:https://melpa.org/packages/org-ql-badge.svg]] [[https://stable.melpa.org/#/org-ql][file:https://stable.melpa.org/packages/org-ql-badge.svg]] -~org-ql~ is a lispy query language for Org files. It allows you to find Org entries matching certain criteria and return a list of them or perform actions on them. Commands are also provided which display matching results. +This package provides a query language for Org files. It offers two syntax styles: Lisp-like sexps and search engine-like keywords. + +It includes three libraries: The =org-ql= library is flexible and may be used as a backend for other tools. The libraries =org-ql-search= and =helm-org-ql= provide interactive search commands and saved views. * Contents :PROPERTIES: :TOC: this :END: - - [[#examples][Examples]] + - [[#screenshots][Screenshots]] - [[#installation][Installation]] - [[#usage][Usage]] - [[#commands][Commands]] @@ -21,77 +23,15 @@ - [[#changelog][Changelog]] - [[#notes][Notes]] -* Examples +* Screenshots -More examples are available in [[examples.org]]. +[[images/org-ql-search.gif]] -#+BEGIN_SRC elisp - ;; Show entries that have any timestamp within the past week. Group - ;; by date using `org-super-agenda' with the `:auto-ts' group. - (org-ql-search (org-agenda-files) - '(ts :from -7 :to today) - :title "Recent Items" - :sort '(date priority todo) - :groups '((:auto-ts t))) +[[images/org-ql-search-snippet.png]] - ;; Show a GTD-style "stuck projects" view: PROJECT tasks that have no - ;; descendants with the NEXT keyword. If you use a "project" tag - ;; instead of the to-do keyword, you could replace (todo "PROJECT") - ;; with (tags "project"). - (org-ql-search (org-agenda-files) - '(and (todo "PROJECT") - (not (descendants (todo "NEXT")))) - :title "Stuck Projects") +[[images/helm-org-ql.gif]] - ;; Integrate `org-ql' into a custom Org Agenda command which inserts - ;; an `org-ql' block before the regular agenda: - (setq org-agenda-custom-commands - '(("ces" "Custom: Agenda and Emacs SOMEDAY [#A] items" - ((org-ql-block '(and (todo "SOMEDAY") - (tags "Emacs") - (priority "A"))) - (agenda))))) - - ;; Return a list of bills coming due, searching all Org Agenda files, - ;; sorted by deadline. The `auto' argument to `deadline' means to match - ;; entries whose deadlines fall within `org-deadline-warning-days'. - ;; `org-ql-query' works like `org-ql-select' but offers arguments named - ;; like SQL queries. - (org-ql-query - :select #'org-get-heading - :from (org-agenda-files) - :where '(and (not (done)) - (tags "bills") - (deadline auto)) - :order-by 'deadline) - ;;=> ("TODO Electric bill" "TODO Water bill") - - ;; If you kept a database of music in an Org file, you could run a - ;; query like this to find tracks composed by Chopin that do not have - ;; their key recorded in the database. `org-ql-search' works like - ;; `org-ql-select' and displays results in an agenda-like buffer: - (org-ql-search "~/org/music.org" - '(and (property "genre" "classical") - (property "composer" "Chopin") - (not (property "key")))) - - ;; Set the tag "Emacs" on every entry in the inbox file that mentions - ;; "Emacs". `org-ql-select' works like `org-ql' but is a function - ;; rather than a macro. The bare-string query "Emacs" is equivalent - ;; to (regexp "Emacs"). - (org-ql-select "~/org/inbox.org" - "Emacs" - :action '(org-toggle-tag "Emacs" 'on)) - - ;; Return a list of Org entry elements in the file "~/org/main.org" - ;; which have the SOMEDAY to-do keyword, are tagged "Emacs", and have - ;; priority B or higher. - (org-ql "~/org/main.org" - (and (todo "SOMEDAY") - (tags "Emacs") - (priority >= "B"))) - ;;=> ((headline (:raw-value "org-board" :begin 1220270 :end 1220403 ...)) ...) -#+END_SRC +[[images/org-ql-view-sidebar.gif]] * Installation :PROPERTIES: @@ -100,9 +40,9 @@ More examples are available in [[examples.org]]. The package may be installed directly from [[https://melpa.org/#/org-ql][MELPA]] or with other tools like [[https://framagit.org/steckerhalter/quelpa][Quelpa]]. -After installation, you can use commands like ~org-ql-search~ immediately. +After installation, you can use the commands without additional configuration. /Note: The command =helm-org-ql= only works if the package =helm-org= is installed; Helm is not a dependency of this package, so it's not automatically installed./ -To use the functions and macros in your own Elisp code, load the libraries ~org-ql~ and/or ~org-ql-agenda~ with e.g. ~(require 'org-ql)~. +To use the functions and macros in your own Elisp code, use libraries =org-ql= and =org-ql-view=. ** Quelpa @@ -134,7 +74,9 @@ These commands and functions are included: - ~org-ql-select~ (function) - ~org-ql-query~ (function) -Feedback on these APIs is welcome. Eventually, after being tested and polished, they will be considered stable. +Feedback on these APIs is welcome. Eventually, after being tested and polished, they will be considered stable. + +Lisp code examples are in [[examples.org]]. ** Commands :PROPERTIES: @@ -143,6 +85,8 @@ Feedback on these APIs is welcome. Eventually, after being tested and polished, *** org-ql-search +/Note: This command supports both sexp queries and [[#non-sexp-query-syntax][non-sexp queries]]./ + 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: @@ -163,22 +107,16 @@ Read ~QUERY~ and search with ~org-ql~. Interactively, prompt for these variable + =g=: Refresh results. + =C-x C-s=: Save query to variable ~org-ql-views~ (accessible with command ~org-ql-view~). -[[images/org-ql-search.gif]] - -Here's an example of using it to generate an agenda-like view for certain files in a directory tree: - -[[images/org-ql-search-snippet.png]] +*Note:* The view buffer is currently put in ~org-agenda-mode~, which means that /some/ Org Agenda commands work, such as jumping to entries and changing item priorities (without necessarily updating the view). This feature is experimental and not guaranteed to work correctly with all commands. (It works to the extent it does because the appropriate text properties are placed on each item, imitating an Agenda buffer.) *** helm-org-ql +/Note: This command uses [[#non-sexp-query-syntax][non-sexp queries]]./ + This command displays matches with Helm. *Note:* Helm is not a package dependency, so this command only works if the package =helm-org= is installed. -Note also that queries in this command are specially handled so that quotes around strings may be omitted for ease of typing. - + Press =C-x C-s= in the Helm session to save the results to an =org-ql-search= buffer. -[[images/helm-org-ql.gif]] - *** org-ql-view Choose and display a view stored in ~org-ql-views~. @@ -187,8 +125,6 @@ Choose and display a view stored in ~org-ql-views~. 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 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=. @@ -201,11 +137,32 @@ Show a sparse tree for ~QUERY~ in ~BUFFER~ and return number of results. The tr ** Queries -A query is a lisp form which may contain arbitrary lisp forms, as well as certain built-in predicates. It is byte-compiled into a predicate function which is tested with point on each heading in an Org buffer; when it returns non-nil, the heading matches the query. +An =org-ql= query is a lisp form which may contain arbitrary lisp forms, as well as certain built-in predicates. It is byte-compiled into a predicate function which is tested with point on each heading in an Org buffer; when it returns non-nil, the heading matches the query. *Notes:* + Bare strings like ~"string"~ are automatically converted to ~(regexp "string")~ predicates. -+ Standard numeric comparator function symbols (~<~, ~<=~, ~>~, ~>=~, ~=~ ) need not be quoted when passed as an argument to these predicates. The resemblance to infix notation is coincidental. See examples in documentation. ++ Standard numeric comparator function symbols (~<~, ~<=~, ~>~, ~>=~, ~=~ ) need not be quoted when passed as an argument to predicates which accept them. The resemblance to infix notation is coincidental. + +*** Non-sexp query syntax +:PROPERTIES: +:TOC: ignore +:END: + +The command =org-ql-search= also accepts, and the command =helm-org-ql= only accepts, an alternative, non-sexp query syntax. The syntax is simple, and a few examples of queries in both syntaxes should suffice. By default, when multiple predicates are used, they are combined with boolean =and=. + +| Sexp syntax | Non-sexp syntax | +|-------------------------------------------------+-----------------------------------------| +| ~(todo)~ | ~todo:~ | +| ~(todo "SOMEDAY")~ | ~todo:SOMEDAY~ | +| ~(todo "SOMEDAY" "WAITING")~ | ~todo:SOMEDAY,WAITING~ | +| ~(ts :on today)~ | ~ts:on=today~ | +| ~(ts-active :from "2017-01-01" :to "2018-01-01")~ | ~ts-active:from=2017-01-01,to=2018-01-01~ | +| ~(clocked :on -1)~ | ~clocked:on=-1~ | +| ~(heading "quoted phrase" "word")~ | ~heading:"quoted phrase",word~ | +| ~(and (tags "book" "books") (priority "A"))~ | ~tags:book,books priority:A~ | +| ~(priority >= B)~ | ~priority:A,B~ | + +Note that the =priority= predicate does not support comparators in the non-sexp syntax, so multiple priorities should be passed instead, as seen in the last example. *** Predicates :PROPERTIES: @@ -297,67 +254,6 @@ However, the ~org-ql-block~ version runs in about 1/5th the time. The variable =org-ql-block-header= may be bound to a string to use as the block header, otherwise the header is formed automatically. -**** Macro: ~org-ql-agenda~ - -This macro is like ~org-ql~, but it presents matching entries in an Agenda-like view. It's compatible with [[https://github.com/alphapapa/org-super-agenda][org-super-agenda]], which provides grouping. For example: - -#+BEGIN_SRC elisp - (org-ql-agenda "~/src/emacs/org-super-agenda/test/test.org" - (and (or (ts-active :on today) - (deadline auto) - (scheduled :to today)) - (not (done))) - :title "My Agenda View" - ;; The `org-super-agenda-groups' setting is used automatically when set, or it - ;; may be overriden by specifying it here: - :super-groups ((:name "Bills" - :tag "bills") - (:todo ("SOMEDAY" "TO-READ" "CHECK" "TO-WATCH" "WATCHING") - :order 7) - (:name "Personal" - :habit t - :tag "personal" - :order 3) - (:todo "WAITING" - :order 6) - (:priority "A" :order 1) - (:priority "B" :order 2) - (:priority "C" :order 2))) -#+END_SRC - -Which presents this buffer: - -[[images/screenshot.png]] - -*Note:* The view buffer is currently put in ~org-agenda-mode~, which means that /some/ Org Agenda commands work, such as jumping to entries and changing item priorities (without necessarily updating the view). This feature is experimental and not guaranteed to work correctly with all commands. (It works to the extent it does because the appropriate text properties are placed on each item, imitating an Agenda buffer.) - -Here are some other examples: - -#+BEGIN_SRC elisp - ;; Show an agenda-like view of items in "~/org/main.org" with TODO and - ;; SOMEDAY keywords which are tagged "computer" or "Emacs" and in the - ;; category "main": - (org-ql-agenda "~/org/main.org" - (and (todo "TODO" "SOMEDAY") - (tags "computer" "Emacs") - (category "main"))) - - ;; Show an agenda-like view of all habits in all agenda files: - (org-ql-agenda - (habit)) - - ;; Show an agenda-like view similar to a "traditional" Org Agenda with - ;; Log Mode turned on. - (org-ql-agenda - (or (and (not (done)) - (or (habit) - (deadline auto) - (scheduled :to today) - (ts-active :on today))) - (closed :on today)) - :sort (date priority todo)) -#+END_SRC - *** Listing / acting-on results **** Function: ~org-ql-select~ @@ -470,6 +366,7 @@ Expands into a call to ~org-ql-select~ with the same arguments. For convenience ** 0.3-pre *Added* ++ Alternative, non-sexp query syntax for commands =org-ql-search= and =helm-org-ql=. See [[#non-sexp-query-syntax][documentation]]. + 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-view-sidebar=. diff --git a/examples.org b/examples.org index ea476a7..830e77e 100644 --- a/examples.org +++ b/examples.org @@ -4,10 +4,72 @@ :PROPERTIES: :TOC: this :END: + - [[#agenda-like-view][Agenda-like view]] + - [[#entries-from-the-past-week][Entries from the past week]] - [[#find-entries-matching-a-certain-custom_id][Find entries matching a certain CUSTOM_ID]] + - [[#listing-bills-coming-due][Listing bills coming due]] + - [[#music-database][Music database]] + - [[#return-org-elements][Return Org elements]] + - [[#set-tags-on-certain-entries][Set tags on certain entries]] - [[#show-entries-with-recent-timestamps][Show entries with recent timestamps]] - [[#stuck-projects-block-agenda][Stuck projects block agenda]] - - [[#listing-bills-coming-due][Listing bills coming due]] + +* Agenda-like view + +Show an agenda-like view, similar to a "traditional" Org Agenda with Log Mode turned on. + +#+BEGIN_SRC elisp + (org-ql-search (org-agenda-files) + '(or (and (not (done)) + (or (habit) + (deadline auto) + (scheduled :to today) + (ts-active :on today))) + (closed :on today)) + :sort '(date priority todo)) +#+END_SRC + +Another example, showing grouping with [[https://github.com/alphapapa/org-super-agenda][org-super-agenda]]: + +#+BEGIN_SRC elisp + (org-ql-search "~/src/emacs/org-super-agenda/test/test.org" + '(and (or (ts-active :on today) + (deadline auto) + (scheduled :to today)) + (not (done))) + :title "My Agenda View" + ;; The `org-super-agenda-groups' setting is used automatically when set, or it + ;; may be overriden by specifying it here: + :super-groups '((:name "Bills" + :tag "bills") + (:todo ("SOMEDAY" "TO-READ" "CHECK" "TO-WATCH" "WATCHING") + :order 7) + (:name "Personal" + :habit t + :tag "personal" + :order 3) + (:todo "WAITING" + :order 6) + (:priority "A" :order 1) + (:priority "B" :order 2) + (:priority "C" :order 2))) +#+END_SRC + +Which displays this buffer: + +[[images/screenshot.png]] + +* Entries from the past week + +Show entries that have any timestamp within the past week. Group by date using =org-super-agenda= with the =:auto-ts= group. + +#+BEGIN_SRC elisp + (org-ql-search (org-agenda-files) + '(ts :from -7 :to today) + :title "Recent Items" + :sort '(date priority todo) + :groups '((:auto-ts t))) +#+END_SRC * Find entries matching a certain =CUSTOM_ID= @@ -23,6 +85,58 @@ Since queries can contain both built-in =org-ql= predicate expressions and arbit Using the =property= predicate as the first clause of the two clauses joined with =and= allows =org-ql= to optimize the query by searching through the buffer directly to entries that set the =CUSTOM_ID= property, which is much faster than testing every entry in a buffer. Also, If the query were only the =string-match= call, it would signal an error on entries that didn't have the property set, because =org-entry-get= would return nil. +* Listing bills coming due + +This uses the example in the readme file, but maps across the elements returned by ~org-ql~ to present a simple list of titles and deadlines. + +#+BEGIN_SRC elisp + (org-ql-query + :select '(list (substring-no-properties (org-get-heading t t)) + (org-entry-get (point) "DEADLINE")) + :from (org-agenda-files) + :where '(and (not (done)) + (tags "bills") + (deadline auto)) + :order-by 'deadline) + ;;=> (("Electric bill" "<2018-08-23 Thu +1m>") + ;; ("Rent" "<2018-09-01 Sat +1m>")) +#+END_SRC + +This could also be put in a script, which could use desktop notifications to remind of bills coming due: [[examples/org-bills-due.el][org-bills-due.el]]. + +* Music database + + If you kept a database of music in an Org file, you could run a query like this to find tracks composed by Chopin that do not have their key recorded in the database. + +#+BEGIN_SRC elisp + (org-ql-search "~/org/music.org" + '(and (property "genre" "classical") + (property "composer" "Chopin") + (not (property "key")))) +#+END_SRC + +* Return Org elements + +Return a list of Org entry elements in the file =~/org/main.org= which have the =SOMEDAY= to-do keyword, are tagged =Emacs=, and have priority B or higher. =org-ql= is the macro version of =org-ql-select=; it does not require quoting the query sexp. + +#+BEGIN_SRC elisp + (org-ql "~/org/main.org" + (and (todo "SOMEDAY") + (tags "Emacs") + (priority >= "B"))) + ;;=> ((headline (:raw-value "org-board" :begin 1220270 :end 1220403 ...)) ...) +#+END_SRC + +* Set tags on certain entries + +Set the tag =Emacs= on every entry in the inbox file that mentions =Emacs=. The bare-string query ="Emacs"= is equivalent to ~(regexp "Emacs")~. + +#+BEGIN_SRC elisp + (org-ql-select "~/org/inbox.org" + "Emacs" + :action '(org-toggle-tag "Emacs" 'on)) +#+END_SRC + * Show entries with recent timestamps You can also access these views with the command ~org-ql-view~. @@ -52,31 +166,13 @@ With this =org-ql-block= agenda view, like: #+BEGIN_SRC elisp (setq org-agenda-custom-commands '(("s" "Stuck Projects" - ((org-ql-block '(and (tags "@project") - (not (done)) - (not (descendants (todo "NEXT"))) - (not (descendants (scheduled)))) - ((org-ql-block-header "Stuck Projects"))))))) + ((org-ql-block '(and (tags "@project") + (not (done)) + (not (descendants (todo "NEXT"))) + (not (descendants (scheduled)))) + ((org-ql-block-header "Stuck Projects"))))))) #+END_SRC -* Listing bills coming due - -This uses the example in the readme file, but maps across the elements returned by ~org-ql~ to present a simple list of titles and deadlines. - -#+BEGIN_SRC elisp - (org-ql (org-agenda-files) - (and (not (done)) - (tags "bills") - (deadline auto)) - :action (list (substring-no-properties (org-get-heading t t)) - (org-entry-get (point) "DEADLINE")) - :sort deadline) - ;;=> (("Electric bill" "<2018-08-23 Thu +1m>") - ;; ("Rent" "<2018-09-01 Sat +1m>")) -#+END_SRC - -This could also be put in a script, which could use desktop notifications to remind of bills coming due: [[examples/org-bills-due.el][org-bills-due.el]]. - * COMMENT Code :noexport: :PROPERTIES: :TOC: ignore diff --git a/helm-org-ql.el b/helm-org-ql.el index 097723b..96604cb 100644 --- a/helm-org-ql.el +++ b/helm-org-ql.el @@ -93,20 +93,18 @@ Based on `helm-map'.") ;;;###autoload (cl-defun helm-org-ql (buffers-files - &optional (no-and current-prefix-arg) (name "helm-org-ql")) - "Display results in BUFFERS-FILES for an `org-ql' query using Helm. -Interactively, search the current buffer. + &key (boolean 'and) (name "helm-org-ql")) + "Display results in BUFFERS-FILES for an `org-ql' non-sexp query using Helm. +Interactively, search the current buffer. Note that this command +only accepts non-sexp, \"plain\" queries. NOTE: Atoms in the query are turned into strings where appropriate, which makes it unnecessary to type quotation marks around words that are intended to be searched for as indepenent strings. -Also, unless NO-AND is non-nil (interactively, with prefix), all -query tokens are wrapped in an implied (and) form. This is -because a query must be a sexp, so when typing multiple clauses, -either (and) or (or) would be required around them, and (and) is -typically more useful, because it narrows down results. +All query tokens are wrapped in the operator BOOLEAN (default +`and'; with prefix, `or'). For example, this raw input: @@ -124,21 +122,34 @@ Is transformed into this query: (and \"something else\" (tags \"funny\"))" (interactive (list (current-buffer))) - (let ((helm-input-idle-delay helm-org-ql-input-idle-delay)) - (helm :prompt (format "Query (boolean %s): " (if no-and - "OR" - "AND")) + (let ((boolean (if current-prefix-arg 'or boolean)) + (helm-input-idle-delay helm-org-ql-input-idle-delay)) + (helm :prompt (format "Query (boolean %s): " (-> boolean symbol-name upcase)) :sources ;; Expansion of `helm-build-sync-source' macro. (helm-make-source name 'helm-source-sync :candidates (lambda nil - (let* ((query (helm-org-ql--input-to-query helm-pattern no-and)) + (let* ((query (org-ql--plain-query helm-pattern boolean)) (window-width (window-width (helm-window)))) (when query (with-current-buffer (helm-buffer-get) (setq helm-org-ql-buffers-files buffers-files)) - (org-ql-select buffers-files query - :action (list 'helm-org-ql--heading window-width))))) + (ignore-errors + ;; Ignore errors that might be caused by partially typed queries. + + ;; FIXME: This doesn't prevent warnings that are errors occurring during + ;; byte-compilation due to partially typed values which can't be correctly + ;; pre-processed, e.g. "ts:to=2019-01-0", which can't be parsed into a + ;; timestamp. A "*Compile-Log*" buffer is displayed with "Error: Wrong type + ;; argument: integerp, nil". With my Helm settings, it's hidden as soon as + ;; the query is typed correctly, so it's tolerable, but I'd prefer to fix it. + ;; I haven't found a way to ignore the error/warning; `with-no-warnings' has + ;; no effect, and we're already using `ignore-errors'. The only solution I + ;; can think of would be to ignore the errors/warnings higher up the chain + ;; where byte-compilation is actually done, but it might not be a good idea + ;; to always ignore such errors/warnings. + (org-ql-select buffers-files query + :action (list 'helm-org-ql--heading window-width)))))) :match #'identity :fuzzy-match nil :multimatch nil @@ -150,7 +161,7 @@ Is transformed into this query: (defun helm-org-ql-agenda-files () "Search agenda files with `helm-org-ql', which see." (interactive) - (helm-org-ql (org-agenda-files) nil "helm-org-ql-agenda-files")) + (helm-org-ql (org-agenda-files) :name "helm-org-ql-agenda-files")) ;;;###autoload (defun helm-org-ql-org-directory () @@ -158,7 +169,7 @@ Is transformed into this query: (interactive) (helm-org-ql (directory-files org-directory 'full (rx ".org" eos)) - nil "helm-org-ql-org-directory")) + :name "helm-org-ql-org-directory")) (defun helm-org-ql-show-marker (marker) "Show heading at MARKER." @@ -182,47 +193,11 @@ Is transformed into this query: (interactive) (let ((buffers-files (with-current-buffer (helm-buffer-get) helm-org-ql-buffers-files)) - (query (helm-org-ql--input-to-query helm-pattern))) + (query (org-ql--plain-query helm-pattern))) (helm-run-after-exit #'org-ql-search buffers-files query))) ;;;; Functions -(defun helm-org-ql--input-to-query (input &optional no-and) - "Return `org-ql' query sexp for string INPUT. -Unless NO-AND is non-nil (interactively, with prefix), all query -tokens are wrapped in an implied (and) form, and plain -symbols (except at the beginning of a sexp) are replaced with -strings." - (unless (s-blank-str? input) - (setf input (format "(%s %s)" (if no-and "or" "and") input)) - (when-let* ((query (ignore-errors - ;; Ignore errors in case input is an - ;; incomplete string or sexp. - (read input)))) - (cl-labels ((rec (form) - ;; Replace some symbols with strings so users don't - ;; have to type quotation marks around all strings. - ;; Not perfect, but should be more useful. - (pcase-exhaustive form - ((pred stringp) form) - (`(deadline auto) form) - ((or '> '>= '< '<= '=) - ;; Comparators, probably for (priority). - form) - ((guard (string-match (rx bos ":" (1+ anything) ":" eos) - (prin1-to-string form))) - ;; An Org tag, not a Lisp keyword. - (prin1-to-string form)) - ((pred keywordp) form) - ((pred numberp) form) - ((guard (string-prefix-p "!" (prin1-to-string form))) - ;; Negation of a string. - `(not ,(substring (prin1-to-string form) 1))) - ((pred atom) (prin1-to-string form)) - ((pred listp) `(,(car form) - ,@(mapcar #'rec (cdr form))))))) - (rec query))))) - (defun helm-org-ql--heading (window-width) "Return string for Helm for heading at point. WINDOW-WIDTH should be the width of the Helm window." diff --git a/images/demo-helm-org-ql.sh b/images/demo-helm-org-ql.sh new file mode 100755 index 0000000..5b67731 --- /dev/null +++ b/images/demo-helm-org-ql.sh @@ -0,0 +1,202 @@ +#!/bin/bash + +# NOTE: Run "setxkbmap us" before running. See https://github.com/jordansissel/xdotool/issues/49 + +# NOTE: should be bound to this function in the Emacs window, like this: + +# (global-set-key [f1] +# (defun gif-screencast-start-or-stop () +# (interactive) +# (if gif-screencast-mode +# (progn +# (gif-screencast-stop) +# (setq gc-cons-threshold gc-cons-threshold-original)) +# (setq gc-cons-threshold-original gc-cons-threshold) +# (setq gc-cons-threshold (* 1024 1024 500)) +# (gif-screencast)))) + +# * Functions + +function ensure_window_name { + if ! [[ $(xdotool getwindowfocus getwindowname) = $1 ]] + then + echo "Wrong window!" >&2 + exit 1 + fi +} + +function key { + xdotool key "$@" +} + +function input { + raw_input "$@" + + # Correct for Helm's input idle delay by sending extra commands to + # make the screenshots be taken. Not sure why two are necessary, + # but they seem to be. + key ctrl+p + sleep 0.26 + key ctrl+p +} + +function raw_input { + xdotool type --delay 200 "$@" +} + +# * Script + +# No matter what I try, xdotool is not working properly to focus/raise/select +# a window. And for some bizarre reason, the "xdotool selectwindow" command +# outputs a completely different window ID than "xdotool search" outputs. In +# fact, the window ID it outputs does not even appear in the output of +# "xprop" for that window. I have no idea where it's getting that ID. + +# So rather than cleanly selecting the proper window in the script, we have to +# do a hacky workaround by sleeping and checking the name of the active +# window. + +sleep 3 +ensure_window_name "data.org" + +# Start gif-screencast +key F1 +sleep 5 + +# M-x helm-org-ql RET +key alt+x +sleep 0.2 +raw_input "helm-org-ql" +key ctrl+e +sleep 0.5 +key Return +sleep 0.5 + +# "Emacs" +input Emacs +sleep 1 + +# "tags:Emacs" +key ctrl+a +input 'tags:' +sleep 1.5 + +# "tags&:Emacs,elisp" +key Left +input "&" +key ctrl+e +input ",elisp" +sleep 2 + +# "universe" +key ctrl+a ctrl+k +input "universe" +sleep 1 + +# "tags:universe,space" +key ctrl+a +input "tags:" +key ctrl+e +input ",space" +sleep 1 + +# "tags&:universe,space" +key ctrl+a Right Right Right Right +input "&" +sleep 2 + +# "deadline:" +key ctrl+a ctrl+k +input "deadline:" +sleep 2 + +# "deadline:to=2017-07-06" +input "to=2019-10-06" +sleep 2 + +# "deadline:to=2017-07-07" +key BackSpace +sleep 0.5 +input "7" +sleep 2 + +# "scheduled:" +key ctrl+a ctrl+k +input "scheduled:" +sleep 2 + +# "scheduled:on=2017-07-04" +input "on=2019-10-04" +sleep 1 + +# "scheduled:on=2017-07-05" +key BackSpace +sleep 0.5 +input "5" +sleep 2 + +# property:agenda-group +key ctrl+a ctrl+k +input "property:agenda-group" +sleep 2 + +# property:agenda-group=plans +input "=plans" +sleep 2 + +# category:ambition +key ctrl+a ctrl+k +input "category:ambition" +sleep 2 + +# ts-inactive: +key ctrl+a ctrl+k +input "ts-inactive:" +sleep 2 + +# closed: +key ctrl+a ctrl+k +input "closed:" +sleep 2 + +# Show match in persistent buffer +key ctrl+j +sleep 2 + +# closed:on=2017-07-04 (which is a day too early) +input "on=2019-10-04" +sleep 2 + +# closed:on=2017-07-05 (which is the closed date) +key BackSpace +input 5 +sleep 2 + +# done: +key ctrl+a ctrl+k +input "done:" +sleep 2 + +# "todo:" +key ctrl+a ctrl+k +input "todo:" +sleep 2 + +# "todo: priority:" +input " priority:" +sleep 1 + +# "todo: priority:A" +input "A" +sleep 1 + +# "todo: priority:A,B" +input ",B" +sleep 2 + +# Save to a view buffer +key ctrl+x ctrl+s +sleep 2 + +# Stop the screencast +key F1 diff --git a/images/helm-org-ql.gif b/images/helm-org-ql.gif index 16b5f34..910c180 100644 Binary files a/images/helm-org-ql.gif and b/images/helm-org-ql.gif differ diff --git a/notes.org b/notes.org index 43569a2..344b550 100644 --- a/notes.org +++ b/notes.org @@ -6,6 +6,194 @@ Note that the built-in sorting only works on Org elements, which is the default ~:action~. So if a different action is used, sorting will not work. In that case, the action should be mapped across the Org element results from outside the ~org-ql~ form. +** TODO [#C] Test caching + +See notes on 1dce9467f25428b5289d3665cd840820969ed65a. It would be good to test the caching explicitly, at least for some queries, because if I were to completely break it again, in such a way that results were stored but retrieval always failed, the tests wouldn't catch it. + +** TODO [#A] Helm command + +In branch =wip/helm-org-ql=. Works really well, should add it and demonstrate it. + +*** TODO Add + +*** TODO Demonstrate + +*** UNDERWAY Parsing non-Lisp queries + +[2019-09-12 Thu 12:56] Lisp is so much easier to deal with, but some people don't like parentheses. So I'm trying to add a non-Lisp-style query syntax. It gets complicated. The =peg= library helps, but its documentation is sparse and incomplete. This seems to work fairly well for single-token queries, but I'm not sure if I can or should cram it all into one parser, or use separate ones for certain keywords. + +#+BEGIN_SRC elisp + (-let* ((input "todo:check|someday") + (input "tags:universe+space") + (input "heading:\"spaced phrase\"") + (input "") + (input "heading:\"spaced phrase\"+another") + combinator + (parsed (peg-parse-string ((predicate (substring keyword) ":" (opt args)) + (keyword (or "heading" "tags" "todo" "property")) + (args (+ (and (or quoted-arg unquoted-arg) (opt separator)))) + (quoted-arg "\"" unquoted-arg "\"") + (unquoted-arg (substring (+ (not (or separator "\"")) (any)))) + (separator (or (and "|" (action (setf combinator 'or))) + (and "+" (action (setf combinator 'and))) + (and ":" (action (setf combinator 'arg)))))) + input 'noerror)) + ((predicate . args) (nreverse parsed))) + (when predicate + (list :predicate predicate :args args :combinator combinator))) + ;;=> (:predicate "heading" :args ("spaced phrase" "another" t) :combinator and) +#+END_SRC + +I don't know where the =t= is coming from. + +The next step is to make it work with multi-token queries. It needs to handle all of the tokens in one parser so it can handle quoted phrases (if we split on spaces, it would split quoted phrases). But that makes getting the arguments out of it more difficult. Probably need to do something like this: + +#+BEGIN_SRC elisp + (-let* ((input "todo:check|someday") + (input "tags:universe+space") + (input "heading:\"spaced phrase\"") + (input "") + (input "heading:\"spaced phrase\"+another") + combinator + (parsed (peg-parse-string ((query (+ (or (and predicate `(pred args -- (list :predicate pred :args args))) + (and plain-string `(s -- (list :predicate 'regexp :args s)))) + (opt (syntax-class whitespace)))) + (plain-string (substring (+ (not (syntax-class whitespace)) (any)))) + (predicate (substring keyword) ":" (opt args)) + (keyword (or "heading" "tags" "todo" "property")) + (args (+ (and (or quoted-arg unquoted-arg) (opt separator)))) + (quoted-arg "\"" unquoted-arg "\"") + (unquoted-arg (substring (+ (not (or separator "\"")) (any)))) + (separator (or (and "|" (action (setf combinator 'or))) + (and "+" (action (setf combinator 'and))) + (and ":" (action (setf combinator 'arg)))))) + input 'noerror))) + parsed) +#+END_SRC + +In which lists are pushed onto the stack and returned, rather than strings. But I don't understand yet exactly how to use the =var= forms to consume input from the "value stack"; I need to study the examples more. I'm also not sure if that will even work with a variable number of arguments. + +This seems to work, but we'll have to parse the args again in a separate step: + +#+BEGIN_SRC elisp + (-let* ((input "todo:check|someday") + (input "tags:universe+space") + (input "heading:\"spaced phrase\"") + (input "") + (input "heading:\"spaced phrase\"+another") + (input "heading:\"spaced phrase\"+another todo:check") + combinator + (parsed (peg-parse-string ((query (+ (or (and predicate `(pred args -- (list :predicate pred :args args))) + (and plain-string `(s -- (list :predicate 'regexp :args s)))) + (opt (+ (syntax-class whitespace) (any))))) + (plain-string (substring (+ (not (syntax-class whitespace)) (any)))) + (predicate (substring keyword) ":" (opt args)) + (keyword (or "heading" "tags" "todo" "property")) + (args (substring (+ (and (or quoted-arg unquoted-arg) (opt separator))))) + (quoted-arg "\"" (+ (not (or separator "\"")) (any)) "\"") + (unquoted-arg (+ (not (or separator "\"" (syntax-class whitespace))) (any))) + (separator (or (and "|" (action (setf combinator 'or))) + (and "+" (action (setf combinator 'and))) + (and ":" (action (setf combinator 'arg)))))) + input 'noerror))) + parsed) + ;;=> (t (:predicate "todo" :args "check") (:predicate "heading" :args "\"spaced phrase\"+another")) +#+END_SRC + +Well, a bit of fiddling (lots of trial-and-error required) produced this: + +#+BEGIN_SRC elisp + (-let* ((input "todo:check|someday") + (input "tags:universe+space") + (input "heading:\"spaced phrase\"") + (input "") + (input "heading:\"spaced phrase\"+another") + (input "heading:\"spaced phrase\"+another todo:check") + combinator + (parsed (peg-parse-string ((query (+ (or (and predicate `(pred args -- (list :predicate pred :args args))) + (and plain-string `(s -- (list :predicate 'regexp :args s)))) + (opt (+ (syntax-class whitespace) (any))))) + (plain-string (substring (+ (not (syntax-class whitespace)) (any)))) + (predicate (substring keyword) ":" (opt args)) + (keyword (or "heading" "tags" "todo" "property")) + (args (list (+ (and (substring (or quoted-arg unquoted-arg)) (opt separator))))) + (quoted-arg "\"" (+ (not (or separator "\"")) (any)) "\"") + (unquoted-arg (+ (not (or separator "\"" (syntax-class whitespace))) (any))) + (separator (or (and "|" (action (setf combinator 'or))) + (and "+" (action (setf combinator 'and))) + (and ":" (action (setf combinator 'arg)))))) + input 'noerror))) + parsed) + ;;=> (t (:predicate "todo" :args ("check")) (:predicate "heading" :args ("\"spaced phrase\"" "another"))) +#+END_SRC + +That seems pretty usable! + +** TODO [#B] Timeline view + +e.g. as mentioned by Samuel Wales at https://lists.gnu.org/archive/html/emacs-orgmode/2019-08/msg00330.html. Prototype code: + +#+BEGIN_SRC elisp + (cl-defun org-ql-timeline (buffers-files query) + (let ((results + (org-ql-select buffers-files + query :action + (lambda () + (let* ((heading-string + (->> (org-element-headline-parser + (line-end-position)) + org-ql--add-markers + org-ql-agenda--format-element)) + (timestamps + (cl-loop with limit = (org-entry-end-position) + while (re-search-forward org-ts-regexp-both + limit t) + collect (ts-parse-org (match-string 0)))) + (timestamp-strings + (->> timestamps + (-sort #'ts<) + (--map (concat " " (ts-format it)))))) + (s-join "\n" (cons heading-string timestamp-strings)))) + :sort '(date)))) + (org-ql-agenda--agenda nil nil :strings results))) + + (org-ql-timeline (org-agenda-files) + '(and "Emacs" (ts))) + + ;; More timeline-like version, organized by date rather than task. + + (cl-defun org-ql-timeline* (buffers-files query &key filter-ts) + (let* ((ts-ht (ht)) + (results (org-ql-select buffers-files + query + :action (lambda () + (let* ((heading-string + (->> (org-element-headline-parser + (line-end-position)) + org-ql--add-markers + org-ql-agenda--format-element)) + (date-timestamps + ;; Each one set to 00:00:00. + (cl-loop with limit = (org-entry-end-position) + while (re-search-forward org-ts-regexp-both + limit t) + collect (->> (match-string 0) + ts-parse-org + (ts-apply :hour 0 :minute 0 :second 0))))) + (setf date-timestamps (delete-dups date-timestamps)) + (when filter-ts + (setf date-timestamps (cl-remove-if-not filter-ts date-timestamps))) + (--each date-timestamps + (push heading-string (gethash it ts-ht))))))) + (tss-sorted (-sort #'ts< (ht-keys ts-ht))) + (strings (cl-loop for ts in tss-sorted + collect (concat "\n" + (propertize (ts-format "%Y-%m-%d" ts) + 'face 'org-agenda-structure)) + append (ht-get ts-ht ts)))) + (org-ql-agenda--agenda nil nil :strings strings))) +#+END_SRC + ** TODO [#A] Outline path in buffers-files arg e.g. diff --git a/org-ql-search.el b/org-ql-search.el index cbe1e5c..c97a1d0 100644 --- a/org-ql-search.el +++ b/org-ql-search.el @@ -58,7 +58,6 @@ 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 @@ -83,7 +82,7 @@ Runs `org-occur-hook' after making the sparse tree." ;;;###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'. + "Search for QUERY with `org-ql'. Interactively, prompt for these variables: BUFFERS-FILES: A list of buffers and/or files to search. @@ -95,6 +94,9 @@ Interactively, may also be: - An expression which evaluates to a list of files/buffers - A space-separated list of file or buffer names +QUERY: An `org-ql' query in either sexp or \"plain string\" +form (see documentation). + SUPER-GROUPS: An `org-super-agenda' group set. See variable `org-super-agenda-groups'. @@ -120,7 +122,7 @@ necessary." ("buffer" (current-buffer)) ((and form (guard (rx bos "("))) (-flatten (eval (read form)))) (else (s-split (rx (1+ space)) else))) - (read-minibuffer "Query: ") + (read-string "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: " @@ -140,13 +142,19 @@ necessary." "todo")) ("Don't sort" nil) (sort (intern sort))))) - (let* ((results (org-ql-select buffers-files query + (let* ((query (cl-etypecase query + (string (if (string-match-p (rx bos (1+ alpha) ":") query) + ;; Parse non-sexp query into sexp query. + (org-ql--plain-query query) + ;; Read sexp query. + (read 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)) - (title (or title (format "%S in %S" query buffers-files))) - (buffer (or buffer (format "%s %s*" org-ql-view-buffer-name-prefix title))) + (buffer (or buffer (format "%s %s*" org-ql-view-buffer-name-prefix (or title query)))) (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) diff --git a/org-ql.el b/org-ql.el index 2934cbd..04ce4bd 100644 --- a/org-ql.el +++ b/org-ql.el @@ -3,7 +3,7 @@ ;; Author: Adam Porter ;; Url: https://github.com/alphapapa/org-ql ;; Version: 0.3-pre -;; 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-pre")) +;; Package-Requires: ((emacs "26.1") (dash "2.13") (dash-functional "1.2.0") (org "9.0") (org-super-agenda "1.2-pre") (ov "1.0.6") (peg "0.6") (s "1.12.0") (ts "0.2-pre")) ;; Keywords: hypermedia, outlines, Org, agenda ;;; Commentary: @@ -41,6 +41,7 @@ (require 'subr-x) (require 'dash) +(require 'dash-functional) (require 'ts) ;;;; Compatibility @@ -115,18 +116,25 @@ This list should not contain any duplicates.") (cl-defmacro org-ql--defpred (name args docstring &rest body) "Define an `org-ql' selector predicate named `org-ql--predicate-NAME'. -ARGS is a `cl-defun'-style argument list. DOCSTRING is the -function's docstring. BODY is the body of the predicate. +NAME may be a symbol or a list of symbols: if a list, the first +is used as the name and the rest are aliases. ARGS is a +`cl-defun'-style argument list. DOCSTRING is the function's +docstring. BODY is the body of the predicate. Predicates will be called with point on the beginning of an Org heading and should return non-nil if the heading's entry is a match." (declare (debug (symbolp listp stringp def-body)) (indent defun)) - (let ((fn-name (intern (concat "org-ql--predicate-" (symbol-name name)))) - (pred-name (intern (symbol-name name)))) + (let* ((aliases (when (listp name) + (cdr name))) + (name (cl-etypecase name + (list (car name)) + (atom name))) + (fn-name (intern (concat "org-ql--predicate-" (symbol-name name)))) + (pred-name (intern (symbol-name name)))) `(progn - (push (list :name ',pred-name :fn ',fn-name :docstring ,docstring :args ',args) org-ql-predicates) + (push (list :name ',pred-name :aliases ',aliases :fn ',fn-name :docstring ,docstring :args ',args) org-ql-predicates) (cl-defun ,fn-name ,args ,docstring ,@body)))) ;;;###autoload @@ -142,6 +150,8 @@ For convenience, arguments should be unquoted." ;;;; Functions +;;;;; Query execution + (define-hash-table-test 'org-ql-hash-test #'equal (lambda (args) (sxhash-equal (prin1-to-string args)))) @@ -272,6 +282,183 @@ NARROW corresponds to the `org-ql-select' argument NARROW." :narrow narrow :sort order-by)) +(defun org-ql--select-cached (&rest args) + "Return results for ARGS and current buffer using cache." + ;; MAYBE: Timeout cached queries. Probably not necessarily since they will be removed when a + ;; buffer is closed, or when a query is run after modifying a buffer. + (-let* (((&plist :query :preamble :action :narrow :preamble-case-fold) args) + (query-cache-key + ;; 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)))) + (if-let* ((buffer-cache (gethash (current-buffer) org-ql-cache)) + (query-cache (cadr buffer-cache)) + (modified-tick (car buffer-cache)) + (buffer-unmodified-p (eq (buffer-modified-tick) modified-tick)) + (cached-result (gethash query-cache-key query-cache))) + (pcase cached-result + ('org-ql-nil nil) + (_ cached-result)) + (let ((new-result (apply #'org-ql--select args))) + (cond ((or (not query-cache) + (not buffer-unmodified-p)) + (puthash (current-buffer) + (list (buffer-modified-tick) + (let ((table (make-hash-table :test 'org-ql-hash-test))) + (puthash query-cache-key (or new-result 'org-ql-nil) table) + table)) + org-ql-cache)) + (t (puthash query-cache-key (or new-result 'org-ql-nil) query-cache))) + new-result)))) + +(cl-defun org-ql--select (&key preamble preamble-case-fold predicate action narrow + &allow-other-keys) + "Return results of mapping function ACTION across entries in current buffer matching function PREDICATE. +If NARROW is non-nil, buffer will not be widened." + ;; Since the mappings are stored in the variable `org-ql-predicates', macros like `flet' + ;; 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. + + ;; MAYBE: Lift the `flet'-equivalent out of this function so it isn't done for each buffer. + (let (orig-fns) + (--each org-ql-predicates + ;; Save original function mappings. + (let ((name (plist-get it :name))) + (push (list :name name :fn (symbol-function name)) orig-fns))) + (unwind-protect + (progn + (--each org-ql-predicates + ;; Set predicate functions. + (fset (plist-get it :name) (plist-get it :fn))) + ;; Run query. + (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. + (cond (preamble (let ((case-fold-search preamble-case-fold)) + (cl-loop while (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)))))))) + (--each orig-fns + ;; Restore original function mappings. + (fset (plist-get it :name) (plist-get it :fn)))))) + +;;;;; Helpers + +(defun org-ql--tags-at (position) + "Return tags for POSITION in current buffer. +Returns cons (INHERITED-TAGS . LOCAL-TAGS)." + ;; I'd like to use `-if-let*', but it doesn't leave non-nil variables + ;; bound in the else clause, so destructured variables that are non-nil, + ;; like found caches, are not available in the else clause. + (if-let* ((buffer-cache (gethash (current-buffer) org-ql-tags-cache)) + (modified-tick (car buffer-cache)) + (tags-cache (cdr buffer-cache)) + (buffer-unmodified-p (eq (buffer-modified-tick) modified-tick)) + (cached-result (gethash position tags-cache))) + ;; Found in cache: return them. + (pcase cached-result + ('org-ql-nil nil) + (_ cached-result)) + ;; Not found in cache: get tags and cache them. + (let* ((local-tags (or (org-ql--get-tags position 'local) + 'org-ql-nil)) + (inherited-tags (or (when org-use-tag-inheritance + (save-excursion + (when (org-up-heading-safe) + (-let* (((inherited local) (org-ql--tags-at (point))) + (tags (when (or inherited local) + (cond ((and (listp inherited) + (listp local)) + (->> (append inherited local) + -non-nil -uniq)) + ((listp inherited) inherited) + ((listp local) local))))) + (cl-typecase org-use-tag-inheritance + (list (setf tags (-intersection tags org-use-tag-inheritance))) + (string (setf tags (--select (string-match org-use-tag-inheritance it) + tags)))) + (pcase org-tags-exclude-from-inheritance + ('nil tags) + (_ (-difference tags org-tags-exclude-from-inheritance))))))) + 'org-ql-nil)) + (all-tags (list inherited-tags local-tags))) + ;; Check caches again, because they may have been set now. + ;; TODO: Is there a clever way we could avoid doing this, or is it inherently necessary? + (setf buffer-cache (gethash (current-buffer) org-ql-tags-cache) + modified-tick (car buffer-cache) + tags-cache (cdr buffer-cache) + buffer-unmodified-p (eq (buffer-modified-tick) modified-tick)) + (unless (and buffer-cache buffer-unmodified-p) + ;; Buffer-local tags cache empty or invalid: make new one. + (setf tags-cache (make-hash-table)) + (puthash (current-buffer) + (cons (buffer-modified-tick) tags-cache) + org-ql-tags-cache)) + (puthash position all-tags tags-cache)))) + +(defun org-ql--add-markers (element) + "Return ELEMENT with Org marker text properties added. +ELEMENT should be an Org element like that returned by +`org-element-headline-parser'. This function should be called +from within ELEMENT's buffer." + ;; NOTE: `org-agenda-new-marker' works, until it doesn't, because...I don't know. It sometimes + ;; raises errors or returns markers that don't point into a buffer. `copy-marker' always works, + ;; of course, but maybe it will leave "dangling" markers, which could affect performance over + ;; time? I don't know, but for now, it seems that we have to use `copy-marker'. + (let* ((marker (copy-marker (org-element-property :begin element))) + (properties (--> (cadr element) + (plist-put it :org-marker marker) + (plist-put it :org-hd-marker marker)))) + (setf (cadr element) properties) + element)) + +;;;;; Query processing + +;; Processing, compiling, etc. for queries. + +;; This error is used for when compiling a query signals an error, +;; making it easier for the UI to avoid spurious warnings, e.g. for +;; partially typed queries in the Helm commands. +(define-error 'org-ql-invalid-query "Invalid Org QL query" 'user-error) + +(defun org-ql--sanity-check-form (form) + "Signal error if any forms in FORM do not have preconditions met. +Or, when possible, fix the problem." + (cl-flet ((check (symbol) + (cl-case symbol + ('done (unless org-done-keywords + ;; NOTE: This check needs to be done from within the Org buffer being checked. + (error "Variable `org-done-keywords' is nil. Are you running this from an Org buffer?")))))) + (cl-loop for elem in form + if (consp elem) + do (progn + (check (car elem)) + (org-ql--sanity-check-form (cdr elem))) + else do (check elem)))) + (defun org-ql--pre-process-query (query) "Return QUERY having been pre-processed. Replaces bare strings with (regexp) selectors, and appropriate @@ -324,14 +511,19 @@ Replaces bare strings with (regexp) selectors, and appropriate `(,pred :to ,to))) ;; Priorities - (`(priority) ;; Match any defined priority by comparing to C. - ;; Note that we quote the comparator again for consistency. - `(priority '>= "C")) - (`(priority ,_letter) element) - (`(priority ,comparator ,letter) + (`(priority ,(and (or '= '< '> '<= '>=) comparator) ,letter) ;; Quote comparator. `(priority ',comparator ,letter)) + ;; Properties. + (`(property ,property . ,value) + ;; Convert keyword property arguments to strings. Non-sexp + ;; queries result in keyword property arguments (because to do + ;; otherwise would require ugly special-casing in the parsing). + (when (keywordp property) + (setf property (substring (symbol-name property) 1))) + (cons 'property (cons property value))) + ;; Tags. (`(,(or 'tags-all 'tags&) . ,tags) `(and ,@(--map `(tags ,it) tags))) ;; MAYBE: -all versions for inherited and local. @@ -346,63 +538,6 @@ Replaces bare strings with (regexp) selectors, and appropriate (_ element)))) (rec query))) -(defmacro org-ql--from-to-on () - "For internal use. -Expands into a form that processes arguments to timestamp-related -predicates." - ;; Several attempts to use `cl-macrolet' and `cl-symbol-macrolet' failed, so I - ;; resorted to this top-level macro. It will do for now. - `(progn - (when on - (setq from on - to on)) - (when from - (setq from (pcase from - ((pred stringp) (ts-parse-fill 'begin from)) - ((pred numberp) (->> (ts-now) - (ts-adjust 'day from) - (ts-apply :hour 0 :minute 0 :second 0))) - ((pred ts-p) from) - ('today (->> (ts-now) - (ts-apply :hour 0 :minute 0 :second 0)))))) - (when to - (setq to (pcase to - ((pred stringp) (ts-parse-fill 'end to)) - ((pred numberp) (->> (ts-now) - (ts-adjust 'day to) - (ts-apply :hour 23 :minute 59 :second 59))) - ((pred ts-p) to) - ('today (->> (ts-now) - (ts-apply :hour 23 :minute 59 :second 59)))))))) - -(defun org-ql--query-predicate (query) - "Return predicate function for QUERY." - (byte-compile - `(lambda () - (cl-macrolet ((clocked (&key from to on) - (org-ql--from-to-on) - `(org-ql--predicate-clocked :from ,from :to ,to)) - (closed (&key from to on) - (org-ql--from-to-on) - `(org-ql--predicate-closed :from ,from :to ,to)) - (deadline (&key from to on) - (org-ql--from-to-on) - `(org-ql--predicate-deadline :from ,from :to ,to)) - (planning (&key from to on) - (org-ql--from-to-on) - `(org-ql--predicate-planning :from ,from :to ,to)) - (scheduled (&key from to on) - (org-ql--from-to-on) - `(org-ql--predicate-scheduled :from ,from :to ,to)) - (ts (&key from to on (type 'both)) - (org-ql--from-to-on) - `(org-ql--predicate-ts :from ,from :to ,to - :regexp ,(pcase type - ('both org-tsr-regexp-both) - ('active org-tsr-regexp) - ('inactive org-ql-tsr-regexp-inactive))))) - ,query)))) - (defun org-ql--query-preamble (query) "Return plist (QUERY PREAMBLE PREAMBLE-CASE-FOLD) for QUERY. When QUERY has a clause with a corresponding preamble, and it's @@ -488,17 +623,12 @@ replace the clause with a preamble." ;; NOTE: This only accepts A, B, or C. I haven't seen ;; other priorities in the wild, so this will do for now. (`(priority) - ;; Any priority. - (setq org-ql-preamble (rx-to-string `(seq bol (1+ "*") (1+ blank) "[#" (in "ABC") "]") t)) + ;; Any priority cookie. + (setq org-ql-preamble (rx-to-string `(seq bol (1+ "*") (1+ blank) (0+ nonl) "[#" (in "ABC") "]") t)) nil) - (`(priority ,letter) - ;; Specific priority without comparator. - ;; MAYBE: Disable case-folding. - (setq org-ql-preamble (rx-to-string `(seq bol (1+ "*") (1+ blank) - (0+ nonl) (1+ blank) - "[#" ,letter "]") t)) - nil) - (`(priority ,comparator ,letter) + (`(priority ,(and (or ''= ''< ''> ''<= ''>=) comparator) ,letter) + ;; Comparator and priority letter. + ;; NOTE: The double-quoted comparators. See below. (let* ((priority-letters '("A" "B" "C")) (index (-elem-index letter priority-letters)) ;; NOTE: Higher priority == lower number. @@ -515,6 +645,13 @@ replace the clause with a preamble." (setq org-ql-preamble (rx-to-string `(seq bol (1+ "*") (1+ blank) (optional (1+ upper) (1+ blank)) "[#" (in ,priorities) "]") t)) nil)) + (`(priority . ,letters) + ;; One or more priorities. + ;; MAYBE: Disable case-folding. + (setq org-ql-preamble (rx-to-string `(seq bol (1+ "*") (1+ blank) + (optional (1+ upper) (1+ blank)) + "[#" (or ,@letters) "]") t)) + nil) ;; Properties. ;; MAYBE: Should case folding be disabled for properties? What about values? @@ -575,173 +712,85 @@ replace the clause with a preamble." (query (-flatten-n 1 query)))) (list :query query :preamble org-ql-preamble :preamble-case-fold preamble-case-fold)))))) -(defun org-ql--select-cached (&rest args) - "Return results for ARGS and current buffer using cache." - ;; MAYBE: Timeout cached queries. Probably not necessarily since they will be removed when a - ;; buffer is closed, or when a query is run after modifying a buffer. - (-let* (((&plist :query :preamble :action :narrow :preamble-case-fold) args) - (query-cache-key - ;; 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)))) - (if-let* ((buffer-cache (gethash (current-buffer) org-ql-cache)) - (query-cache (cadr buffer-cache)) - (modified-tick (car buffer-cache)) - (buffer-unmodified-p (eq (buffer-modified-tick) modified-tick)) - (cached-result (gethash query-cache-key query-cache))) - (pcase cached-result - ('org-ql-nil nil) - (_ cached-result)) - (let ((new-result (apply #'org-ql--select args))) - (cond ((or (not query-cache) - (not buffer-unmodified-p)) - (puthash (current-buffer) - (list (buffer-modified-tick) - (let ((table (make-hash-table :test 'org-ql-hash-test))) - (puthash query-cache-key (or new-result 'org-ql-nil) table) - table)) - org-ql-cache)) - (t (puthash query-cache-key (or new-result 'org-ql-nil) query-cache))) - new-result)))) +(defmacro org-ql--from-to-on () + "For internal use. +Expands into a form that processes arguments to timestamp-related +predicates." + ;; Several attempts to use `cl-macrolet' and `cl-symbol-macrolet' failed, so I + ;; resorted to this top-level macro. It will do for now. + `(progn + (when on + (setq from on + to on)) + (when from + (setq from (pcase from + ((or 'today "today") (->> (ts-now) + (ts-apply :hour 0 :minute 0 :second 0))) + ((pred numberp) (->> (ts-now) + (ts-adjust 'day from) + (ts-apply :hour 0 :minute 0 :second 0))) + ((and (pred stringp) + (guard (ignore-errors (cl-parse-integer from)))) + ;; The `pcase' `let' pattern doesn't bind values in the + ;; body forms, so we have to parse the integer again. + (->> (ts-now) + (ts-adjust 'day (cl-parse-integer from)) + (ts-apply :hour 0 :minute 0 :second 0))) + ((pred stringp) (ts-parse-fill 'begin from)) + ((pred ts-p) from)))) + (when to + (setq to (pcase to + ((or 'today "today") (->> (ts-now) + (ts-apply :hour 23 :minute 59 :second 59))) + ((pred numberp) (->> (ts-now) + (ts-adjust 'day to) + (ts-apply :hour 23 :minute 59 :second 59))) + ((and (pred stringp) + (guard (ignore-errors (cl-parse-integer to)))) + ;; The `pcase' `let' pattern doesn't bind values in the + ;; body forms, so we have to parse the integer again. + (->> (ts-now) + (ts-adjust 'day (cl-parse-integer to)) + (ts-apply :hour 23 :minute 59 :second 59))) + ((pred stringp) (ts-parse-fill 'end to)) + ((pred ts-p) to)))))) -(cl-defun org-ql--select (&key preamble preamble-case-fold predicate action narrow - &allow-other-keys) - "Return results of mapping function ACTION across entries in current buffer matching function PREDICATE. -If NARROW is non-nil, buffer will not be widened." - ;; Since the mappings are stored in the variable `org-ql-predicates', macros like `flet' - ;; 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. +(defun org-ql--byte-compile-warning (_string _pos _fill level) + "Signal an `org-ql-invalid-query' error. +Arguments STRING, POS, FILL, and LEVEL are according to +`byte-compile-log-warning-function'." + ;; Used as the `byte-compile-log-warning-function' in `org-ql--query-preamble'. + (signal 'org-ql-invalid-query level)) - ;; MAYBE: Lift the `flet'-equivalent out of this function so it isn't done for each buffer. - (let (orig-fns) - (--each org-ql-predicates - ;; Save original function mappings. - (let ((name (plist-get it :name))) - (push (list :name name :fn (symbol-function name)) orig-fns))) - (unwind-protect - (progn - (--each org-ql-predicates - ;; Set predicate functions. - (fset (plist-get it :name) (plist-get it :fn))) - ;; Run query. - (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. - (cond (preamble (let ((case-fold-search preamble-case-fold)) - (cl-loop while (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)))))))) - (--each orig-fns - ;; Restore original function mappings. - (fset (plist-get it :name) (plist-get it :fn)))))) - -(defun org-ql--tags-at (position) - "Return tags for POSITION in current buffer. -Returns cons (INHERITED-TAGS . LOCAL-TAGS)." - ;; I'd like to use `-if-let*', but it doesn't leave non-nil variables - ;; bound in the else clause, so destructured variables that are non-nil, - ;; like found caches, are not available in the else clause. - (if-let* ((buffer-cache (gethash (current-buffer) org-ql-tags-cache)) - (modified-tick (car buffer-cache)) - (tags-cache (cdr buffer-cache)) - (buffer-unmodified-p (eq (buffer-modified-tick) modified-tick)) - (cached-result (gethash position tags-cache))) - ;; Found in cache: return them. - (pcase cached-result - ('org-ql-nil nil) - (_ cached-result)) - ;; Not found in cache: get tags and cache them. - (let* ((local-tags (or (org-ql--get-tags position 'local) - 'org-ql-nil)) - (inherited-tags (or (when org-use-tag-inheritance - (save-excursion - (when (org-up-heading-safe) - (-let* (((inherited local) (org-ql--tags-at (point))) - (tags (when (or inherited local) - (cond ((and (listp inherited) - (listp local)) - (->> (append inherited local) - -non-nil -uniq)) - ((listp inherited) inherited) - ((listp local) local))))) - (cl-typecase org-use-tag-inheritance - (list (setf tags (-intersection tags org-use-tag-inheritance))) - (string (setf tags (--select (string-match org-use-tag-inheritance it) - tags)))) - (pcase org-tags-exclude-from-inheritance - ('nil tags) - (_ (-difference tags org-tags-exclude-from-inheritance))))))) - 'org-ql-nil)) - (all-tags (list inherited-tags local-tags))) - ;; Check caches again, because they may have been set now. - ;; TODO: Is there a clever way we could avoid doing this, or is it inherently necessary? - (setf buffer-cache (gethash (current-buffer) org-ql-tags-cache) - modified-tick (car buffer-cache) - tags-cache (cdr buffer-cache) - buffer-unmodified-p (eq (buffer-modified-tick) modified-tick)) - (unless (and buffer-cache buffer-unmodified-p) - ;; Buffer-local tags cache empty or invalid: make new one. - (setf tags-cache (make-hash-table)) - (puthash (current-buffer) - (cons (buffer-modified-tick) tags-cache) - org-ql-tags-cache)) - (puthash position all-tags tags-cache)))) - -;;;;; Helpers - -(defun org-ql--add-markers (element) - "Return ELEMENT with Org marker text properties added. -ELEMENT should be an Org element like that returned by -`org-element-headline-parser'. This function should be called -from within ELEMENT's buffer." - ;; NOTE: `org-agenda-new-marker' works, until it doesn't, because...I don't know. It sometimes - ;; raises errors or returns markers that don't point into a buffer. `copy-marker' always works, - ;; of course, but maybe it will leave "dangling" markers, which could affect performance over - ;; time? I don't know, but for now, it seems that we have to use `copy-marker'. - (let* ((marker (copy-marker (org-element-property :begin element))) - (properties (--> (cadr element) - (plist-put it :org-marker marker) - (plist-put it :org-hd-marker marker)))) - (setf (cadr element) properties) - element)) - -(defun org-ql--sanity-check-form (form) - "Signal error if any forms in FORM do not have preconditions met. -Or, when possible, fix the problem." - (cl-flet ((check (symbol) - (cl-case symbol - ('done (unless org-done-keywords - ;; NOTE: This check needs to be done from within the Org buffer being checked. - (error "Variable `org-done-keywords' is nil. Are you running this from an Org buffer?")))))) - (cl-loop for elem in form - if (consp elem) - do (progn - (check (car elem)) - (org-ql--sanity-check-form (cdr elem))) - else do (check elem)))) +(defun org-ql--query-predicate (query) + "Return predicate function for QUERY." + ;; Use custom log function to prevent warnings for e.g. partially typed queries. + (let ((byte-compile-log-warning-function #'org-ql--byte-compile-warning)) + (byte-compile + `(lambda () + (cl-macrolet ((clocked (&key from to on) + (org-ql--from-to-on) + `(org-ql--predicate-clocked :from ,from :to ,to)) + (closed (&key from to on) + (org-ql--from-to-on) + `(org-ql--predicate-closed :from ,from :to ,to)) + (deadline (&key from to on) + (org-ql--from-to-on) + `(org-ql--predicate-deadline :from ,from :to ,to)) + (planning (&key from to on) + (org-ql--from-to-on) + `(org-ql--predicate-planning :from ,from :to ,to)) + (scheduled (&key from to on) + (org-ql--from-to-on) + `(org-ql--predicate-scheduled :from ,from :to ,to)) + (ts (&key from to on (type 'both)) + (org-ql--from-to-on) + `(org-ql--predicate-ts :from ,from :to ,to + :regexp ,(pcase type + ('both org-tsr-regexp-both) + ('active org-tsr-regexp) + ('inactive org-ql-tsr-regexp-inactive))))) + ,query))))) ;;;;; Predicates @@ -811,7 +860,8 @@ With KEYWORDS, return non-nil if its keyword is one of KEYWORDS (a list of strin ;; NOTE: This was a defsubst before being defined with the macro. Might be good to make it a defsubst again. (or (apply #'org-ql--predicate-todo org-done-keywords))) -(org-ql--defpred tags (&rest tags) +(org-ql--defpred (tags tags-all tags&) (&rest tags) + ;; NOTE: tags-all and tags& are "virtual" predicates that are handled by query pre-processing. "Return non-nil if current heading has one or more of TAGS (a list of strings). Tests both inherited and local tags." (cl-macrolet ((tags-p (tags) @@ -826,7 +876,7 @@ Tests both inherited and local tags." (when (tags-p local) (seq-intersection tags local)))))))) -(org-ql--defpred tags-inherited (&rest tags) +(org-ql--defpred (tags-inherited tags-i itags) (&rest tags) "Return non-nil if current heading's inherited tags include one or more of TAGS (a list of strings). If TAGS is nil, return non-nil if heading has any inherited tags." (cl-macrolet ((tags-p (tags) @@ -838,7 +888,7 @@ If TAGS is nil, return non-nil if heading has any inherited tags." (otherwise (when (tags-p inherited) (seq-intersection tags inherited))))))) -(org-ql--defpred tags-local (&rest tags) +(org-ql--defpred (tags-local tags-l ltags) (&rest tags) "Return non-nil if current heading's local tags include one or more of TAGS (a list of strings). If TAGS is nil, return non-nil if heading has any local tags." (cl-macrolet ((tags-p (tags) @@ -871,44 +921,46 @@ COMPARATOR may be `<', `<=', `>', or `>='." ((pred symbolp) ;; Compare with function (funcall level-or-comparator outline-level level))))) -(org-ql--defpred priority (&optional comparator-or-priority priority) +(org-ql--defpred priority (&rest args) "Return non-nil if current heading has a certain priority. -COMPARATOR-OR-PRIORITY should be either a comparator function, -like `<=', or a priority string, like \"A\" (in which case (`=' -will be the comparator). If COMPARATOR-OR-PRIORITY is a -comparator, PRIORITY should be a priority string. If both -arguments are nil, return non-nil if heading has any defined -priority." - (let* (comparator) - (cond ((null priority) - ;; No comparator given: compare only given priority with = - (setq priority comparator-or-priority - comparator '=)) - (t - ;; Both comparator and priority given - (setq comparator comparator-or-priority))) - (setq comparator (cl-case comparator - ;; Invert comparator because higher priority means lower number - (< '>) - (> '<) - (<= '>=) - (>= '<=) - (= '=) - (otherwise (user-error "Invalid comparator: %s" comparator)))) - (setq priority (* 1000 (- org-lowest-priority (string-to-char priority)))) - (when-let ((item-priority (save-excursion - (save-match-data - ;; TODO: Is the save-match-data above necessary? - (when (and (looking-at org-heading-regexp) - (save-match-data - (string-match org-priority-regexp (match-string 0)))) - ;; TODO: Items with no priority - ;; should not be the same as B - ;; priority. That's not very - ;; useful IMO. Better to do it - ;; like in org-super-agenda. - (org-get-priority (match-string 0))))))) - (funcall comparator priority item-priority)))) +ARGS may be either a list of one or more priority letters as +strings, or a comparator function symbol followed by a priority +letter string. For example: + + (priority \"A\") + (priority \"A\" \"B\") + (priority '>= \"B\") + +Note that items without a priority cookie never match this +predicate (while Org itself considers items without a cookie to +have the default priority, which, by default, is equal to +priority B)." + ;; NOTE: This treats priorities differently than Org proper treats them, in that + ;; items without a priority cookie never match this predicate, even though Org + ;; itself would consider un-cookied items to have a default numeric priority + ;; value. We do this because it doesn't seem very useful or intuitive for a + ;; query like (priority "B") to match an item that has no priority cookie. + ;; TODO: Convert priority arg(s) to numeric values in pre-processing. + (when-let* ((item-priority (save-excursion + (save-match-data + ;; TODO: Is the save-match-data above necessary? + (when (and (looking-at org-heading-regexp) + (save-match-data + (string-match org-priority-regexp (match-string 0)))) + (org-get-priority (match-string 0))))))) + ;; Item has a priority: compare it. + (pcase args + ('nil + ;; No arguments: return non-nil. + t) + (`(,(and (or '= '< '> '<= '>=) comparator) ,priority-arg) + ;; Comparator and priority arguments given: compare item priority using them. + (funcall comparator item-priority + (* 1000 (- org-lowest-priority (string-to-char priority-arg))))) + (_ + ;; List of priorities given as arguments: compare each of them to item priority using =. + (cl-loop for priority-arg in args + thereis (= item-priority (* 1000 (- org-lowest-priority (string-to-char priority-arg))))))))) (org-ql--defpred habit () "Return non-nil if entry is a habit." @@ -1080,11 +1132,13 @@ parseable by `parse-time-string' which may omit the time value." (org-ql--predicate-ts :from from :to to :regexp org-scheduled-time-regexp :match-group 1 :limit (line-end-position 2))) -(org-ql--defpred ts (&key from to _on regexp (match-group 0) (limit (org-entry-end-position))) - ;; The underscore before `on' prevents "unused lexical variable" warnings, - ;; because we pre-process that argument in a macro before this function is - ;; called. The `regexp' argument is also provided by the macro and is not - ;; to be given by the user, so it is omitted from the docstring. +(org-ql--defpred (ts ts-active ts-a ts-inactive ts-i) + (&key from to _on regexp (match-group 0) (limit (org-entry-end-position))) + ;; NOTE: Arguments to this predicate are pre-processed in `org-ql--pre-process-query'. + ;; The underscore before `on' prevents "unused lexical variable" warnings due to the + ;; pre-processing converting that argument to FROM and TO. The `regexp' argument is + ;; also provided by the pre-processing and is not to be given by the user. FROM and + ;; TO are actually expected to be `ts' structs. The docstring is written for users. "Return non-nil if current entry has a timestamp in given period. If no arguments are specified, return non-nil if entry has any timestamp. @@ -1108,8 +1162,6 @@ the end of the entry, i.e. the position returned by bound to a different positiion, e.g. for planning lines, the end of the line after the heading." ;; TODO: DRY this with the clocked predicate. - ;; NOTE: FROM and TO are actually expected to be `ts' structs. The docstring is written - ;; for end users, for which the arguments are pre-processed by `org-ql-select'. (cl-macrolet ((next-timestamp () `(when (re-search-forward regexp limit t) (ts-parse-org (match-string match-group)))) @@ -1204,6 +1256,68 @@ A and B are Org headline elements." (a-priority t) (b-priority nil))))) +;;;;; Plain query parsing + +;; This section implements parsing of "plain," non-Lisp queries using the `peg' +;; library. NOTE: This needs to appear after the predicates are defined. + +(require 'peg) + +;; Fix compiler warnings probably caused by `peg' not using lexical-binding. +;; TODO: File bug report upstream. +(defvar peg-errors nil) +(defvar peg-stack nil) + +(cl-eval-when (compile load eval) + ;; This `eval-when' is necessary, otherwise the macro does not define + ;; the function correctly, apparently because `org-ql-predicates' + ;; ends up being not defined correctly at expansion time. + + (defmacro org-ql--def-plain-query-fn () + "Define function `org-ql--input-query'. +Builds the PEG expression using predicates defined in +`org-ql-predicates' and `org-ql-predicates-extra-aliases'." + (let* ((predicates (--map (symbol-name (plist-get it :name)) + org-ql-predicates)) + (aliases (->> org-ql-predicates + (--map (plist-get it :aliases)) + -non-nil + -flatten + (-map #'symbol-name))) + (predicates (->> (append predicates aliases) + -uniq + ;; Sort the keywords longest-first to work around what seems to be an + ;; obscure bug in `peg': when one keyword is a substring of another, + ;; and the shorter one is listed first, the shorter one fails to match. + (-sort (-on #'> #'length))))) + `(cl-defun org-ql--plain-query (input &optional (boolean 'and)) + "Return query parsed from plain query string INPUT. +Multiple predicates are combined with BOOLEAN." + (unless (s-blank-str? input) + (let* ((query (peg-parse-string + ((query (+ (or (and predicate-with-args `(pred args -- (cons (intern pred) args))) + (and predicate-without-args `(pred -- (list (intern pred)))) + (and plain-string `(s -- (list 'regexp s)))) + (opt (+ (syntax-class whitespace) (any))))) + (plain-string (substring (+ (not (syntax-class whitespace)) (any)))) + (predicate-with-args (substring predicate) ":" args) + (predicate-without-args (substring predicate) ":") + (predicate (or ,@predicates)) + (args (list (+ (and (or keyword-arg quoted-arg unquoted-arg) (opt separator))))) + (keyword-arg (and keyword "=" `(kw -- (intern (concat ":" kw))))) + (keyword (substring (+ (not (or separator "=" "\"" (syntax-class whitespace))) (any)))) + (quoted-arg "\"" (substring (+ (not (or separator "\"")) (any))) "\"") + (unquoted-arg (substring (+ (not (or separator "\"" (syntax-class whitespace))) (any)))) + (separator "," )) + input 'noerror))) + ;; Discard the t that `peg-parse-string' always returns as the first + ;; element. I don't know what it means, but we don't want it. + (if (> (length (cdr query)) 1) + (cons boolean (nreverse (cdr query))) + (cadr query))))))) + + (org-ql--def-plain-query-fn)) + ;;;; Footer (provide 'org-ql) diff --git a/tests/test-org-ql.el b/tests/test-org-ql.el index 4092642..c7b95bc 100644 --- a/tests/test-org-ql.el +++ b/tests/test-org-ql.el @@ -227,6 +227,52 @@ RESULTS should be a list of strings as returned by :preamble (rx bol (>= 2 "*") " ") :preamble-case-fold t))))) + (describe "Plain query parsing" + + ;; TODO: Other predicates. + + (it "Regexp predicates" + (expect (org-ql--plain-query "scheduled") + ;; No colon after keyword, so not a predicate query. + :to-equal '(regexp "scheduled")) + (expect (org-ql--plain-query "regexp:word") + :to-equal '(regexp "word")) + (expect (org-ql--plain-query "regexp:\"quoted phrase\"") + :to-equal '(regexp "quoted phrase"))) + (it "Timestamp-based predicates" + (expect (org-ql--plain-query "scheduled:on=2017-07-07") + :to-equal '(scheduled :on "2017-07-07")) + (expect (org-ql--plain-query "deadline:from=2017-07-07,to=2017-07-09") + :to-equal '(deadline :from "2017-07-07" :to "2017-07-09")) + (expect (org-ql--plain-query "planning:from=2017-07-07") + :to-equal '(planning :from "2017-07-07")) + (expect (org-ql--plain-query "closed:from=2017-07-07") + :to-equal '(closed :from "2017-07-07")) + (expect (org-ql--plain-query "ts-active:to=2017-07-07") + :to-equal '(ts-active :to "2017-07-07")) + (expect (org-ql--plain-query "ts-inactive:to=2017-07-07") + :to-equal '(ts-inactive :to "2017-07-07")) + (expect (org-ql--plain-query "ts-a:to=2017-07-07") + :to-equal '(ts-a :to "2017-07-07")) + (expect (org-ql--plain-query "ts-i:on=2017-07-07") + :to-equal '(ts-i :on "2017-07-07")) + (expect (org-ql--plain-query "ts:") + :to-equal '(ts)) + (expect (org-ql--plain-query "clocked:") + :to-equal '(clocked))) + (it "To-do predicates" + (expect (org-ql--plain-query "todo:") + :to-equal '(todo)) + (expect (org-ql--plain-query "todo:TODO") + :to-equal '(todo "TODO")) + (expect (org-ql--plain-query "todo:TODO,SOMEDAY") + :to-equal '(todo "TODO" "SOMEDAY"))) + (it "Compound queries" + (expect (org-ql--plain-query "todo:SOMEDAY ts-a:from=2020-01-01,to=2021-01-01") + :to-equal '(and (todo "SOMEDAY") (ts-a :from "2020-01-01" :to "2021-01-01"))) + (expect (org-ql--plain-query "regexp:\"quoted phrase\" todo:SOMEDAY") + :to-equal '(and (regexp "quoted phrase") (todo "SOMEDAY"))))) + (describe "Query results" ;; TODO: Other predicates.