This commit is contained in:
Adam Porter 2021-06-18 23:55:42 -05:00
parent a24b41d7e5
commit 26c58c6c77
3 changed files with 118 additions and 52 deletions

130
org-ql.el
View file

@ -146,12 +146,16 @@ This list should not contain any duplicates."))
(defvar org-ql-regexp-part-ts-date (defvar org-ql-regexp-part-ts-date
(rx (repeat 4 digit) "-" (repeat 2 digit) "-" (repeat 2 digit) (rx (repeat 4 digit) "-" (repeat 2 digit) "-" (repeat 2 digit)
;; Day of week ;; Day of week
(optional " " (1+ alpha)) (optional " " (1+ alpha)))
;; Repeaters (not sure if the colon is necessary, but it's in the org.el one)
(optional (repeat 1 2 (seq " " (repeat 1 2 (any "-+:")) (1+ digit) (any "hdwmy")))))
"Matches the inner, date part of an Org timestamp, both active and inactive. "Matches the inner, date part of an Org timestamp, both active and inactive.
Also matches optional day-of-week and repeaters. Used to build Also matches optional day-of-week. Used to build other timestamp
other timestamp regexps.") regexps.")
(defvar org-ql-regexp-part-ts-repeaters
;; Repeaters (not sure if the colon is necessary, but it's in the org.el one)
(rx (repeat 1 2 (seq " " (repeat 1 2 (any "-+:")) (1+ digit) (any "hdwmy"))))
"Matches the repeater part of an Org timestamp.
Includes leading space character.")
(defvar org-ql-regexp-part-ts-time (defvar org-ql-regexp-part-ts-time
(rx " " (repeat 1 2 digit) ":" (repeat 2 digit)) (rx " " (repeat 1 2 digit) ":" (repeat 2 digit))
@ -159,40 +163,57 @@ other timestamp regexps.")
Includes leading space character. Used to build other timestamp Includes leading space character. Used to build other timestamp
regexps.") regexps.")
;; NOTE: The inactive timestamp regexps don't allow repeaters. I don't know if this is
;; officially correct, but it seems to make sense, and would be easy to change if necessary.
(defvar org-ql-regexp-ts-both (defvar org-ql-regexp-ts-both
(rx-to-string (rx-to-string
`(or (seq "<" (regexp ,org-ql-regexp-part-ts-date) (optional (regexp ,org-ql-regexp-part-ts-time)) ">") `(or (seq "<" (regexp ,org-ql-regexp-part-ts-date)
(seq "[" (regexp ,org-ql-regexp-part-ts-date) (optional (regexp ,org-ql-regexp-part-ts-time)) "]"))) (optional (regexp ,org-ql-regexp-part-ts-time))
(optional (regexp ,org-ql-regexp-part-ts-repeaters)) ">")
(seq "[" (regexp ,org-ql-regexp-part-ts-date)
(optional (regexp ,org-ql-regexp-part-ts-time)))))
"Matches both active and inactive Org timestamps, with or without time.") "Matches both active and inactive Org timestamps, with or without time.")
(defvar org-ql-regexp-ts-both-with-time (defvar org-ql-regexp-ts-both-with-time
(rx-to-string `(or (seq "<" (regexp ,org-ql-regexp-part-ts-date) (regexp ,org-ql-regexp-part-ts-time) ">") (rx-to-string `(or (seq "<" (regexp ,org-ql-regexp-part-ts-date)
(seq "[" (regexp ,org-ql-regexp-part-ts-date) (regexp ,org-ql-regexp-part-ts-time) "]"))) (regexp ,org-ql-regexp-part-ts-time)
(optional (regexp ,org-ql-regexp-part-ts-repeaters)) ">")
(seq "[" (regexp ,org-ql-regexp-part-ts-date)
(regexp ,org-ql-regexp-part-ts-time) "]")))
"Matches both active and inactive Org timestamps, with time.") "Matches both active and inactive Org timestamps, with time.")
(defvar org-ql-regexp-ts-both-without-time (defvar org-ql-regexp-ts-both-without-time
(rx-to-string `(or (seq "<" (regexp ,org-ql-regexp-part-ts-date) ">") (rx-to-string `(or (seq "<" (regexp ,org-ql-regexp-part-ts-date)
(optional (regexp ,org-ql-regexp-part-ts-repeaters)) ">")
(seq "[" (regexp ,org-ql-regexp-part-ts-date) "]"))) (seq "[" (regexp ,org-ql-regexp-part-ts-date) "]")))
"Matches both active and inactive Org timestamps, without time.") "Matches both active and inactive Org timestamps, without time.")
(defvar org-ql-regexp-ts-active (defvar org-ql-regexp-ts-active
(rx-to-string `(seq "<" (regexp ,org-ql-regexp-part-ts-date) (optional (regexp ,org-ql-regexp-part-ts-time)) ">")) (rx-to-string `(seq "<" (regexp ,org-ql-regexp-part-ts-date)
(optional (regexp ,org-ql-regexp-part-ts-time))
(optional (regexp ,org-ql-regexp-part-ts-repeaters)) ">"))
"Matches active Org timestamps, with or without time.") "Matches active Org timestamps, with or without time.")
(defvar org-ql-regexp-ts-active-with-time (defvar org-ql-regexp-ts-active-with-time
(rx-to-string `(seq "<" (regexp ,org-ql-regexp-part-ts-date) (regexp ,org-ql-regexp-part-ts-time) ">")) (rx-to-string `(seq "<" (regexp ,org-ql-regexp-part-ts-date)
(regexp ,org-ql-regexp-part-ts-time)
(optional (regexp ,org-ql-regexp-part-ts-repeaters)) ">"))
"Matches active Org timestamps, with time.") "Matches active Org timestamps, with time.")
(defvar org-ql-regexp-ts-active-without-time (defvar org-ql-regexp-ts-active-without-time
(rx-to-string `(seq "<" (regexp ,org-ql-regexp-part-ts-date) ">")) (rx-to-string `(seq "<" (regexp ,org-ql-regexp-part-ts-date)
(optional (regexp ,org-ql-regexp-part-ts-repeaters)) ">"))
"Matches active Org timestamps, without time.") "Matches active Org timestamps, without time.")
(defvar org-ql-regexp-ts-inactive (defvar org-ql-regexp-ts-inactive
(rx-to-string `(seq "[" (regexp ,org-ql-regexp-part-ts-date) (optional (regexp ,org-ql-regexp-part-ts-time)) "]")) (rx-to-string `(seq "[" (regexp ,org-ql-regexp-part-ts-date)
(optional (regexp ,org-ql-regexp-part-ts-time))"]"))
"Matches inactive Org timestamps, with or without time.") "Matches inactive Org timestamps, with or without time.")
(defvar org-ql-regexp-ts-inactive-with-time (defvar org-ql-regexp-ts-inactive-with-time
(rx-to-string `(seq "[" (regexp ,org-ql-regexp-part-ts-date) (regexp ,org-ql-regexp-part-ts-time) "]")) (rx-to-string `(seq "[" (regexp ,org-ql-regexp-part-ts-date)
(regexp ,org-ql-regexp-part-ts-time)"]"))
"Matches inactive Org timestamps, with time.") "Matches inactive Org timestamps, with time.")
(defvar org-ql-regexp-ts-inactive-without-time (defvar org-ql-regexp-ts-inactive-without-time
@ -200,33 +221,54 @@ regexps.")
"Matches inactive Org timestamps, without time.") "Matches inactive Org timestamps, without time.")
(defvar org-ql-regexp-planning (defvar org-ql-regexp-planning
(rx-to-string `(seq bow (or "CLOSED" "SCHEDULED" "DEADLINE") ":" (0+ " ") (rx-to-string `(seq bow (or (seq "CLOSED" ":" (0+ " ")
(group (regexp ,org-ql-regexp-ts-both)))) (group-n 1 (regexp ,org-ql-regexp-ts-inactive)))
"Matches DEADLINE or SCHEDULED keyword with timestamp, with or without time.") (seq (or "DEADLINE" "SCHEDULED") ":" (0+ " ")
(group-n 1 (regexp ,org-ql-regexp-ts-active))))))
"Matches CLOSED, DEADLINE or SCHEDULED keyword with timestamp, with or without time.")
(defvar org-ql-regexp-planning-with-time (defvar org-ql-regexp-planning-with-time
(rx-to-string `(seq bow (or "CLOSED" "SCHEDULED" "DEADLINE") ":" (0+ " ") (rx-to-string `(seq bow (or (seq "CLOSED" ":" (0+ " ")
(group (regexp ,org-ql-regexp-ts-both-with-time)))) (group-n 1 (regexp ,org-ql-regexp-ts-inactive-with-time)))
"Matches DEADLINE or SCHEDULED keyword with timestamp, with time.") (seq (or "DEADLINE" "SCHEDULED") ":" (0+ " ")
(group-n 1 (regexp ,org-ql-regexp-ts-active-with-time))))))
"Matches CLOSED, DEADLINE or SCHEDULED keyword with timestamp, with time.")
(defvar org-ql-regexp-planning-without-time (defvar org-ql-regexp-planning-without-time
(rx-to-string `(seq bow (or "CLOSED" "SCHEDULED" "DEADLINE") ":" (0+ " ") (rx-to-string `(seq bow (or (seq "CLOSED" ":" (0+ " ")
(group (regexp ,org-ql-regexp-ts-both-without-time)))) (group-n 1 (regexp ,org-ql-regexp-ts-inactive-without-time)))
"Matches DEADLINE or SCHEDULED keyword with timestamp, without time.") (seq (or "DEADLINE" "SCHEDULED") ":" (0+ " ")
(group-n 1 (regexp ,org-ql-regexp-ts-active-without-time))))))
"Matches CLOSED, DEADLINE or SCHEDULED keyword with timestamp, without time.")
(defvar org-ql-regexp-deadline
(rx-to-string `(seq bow "DEADLINE" ":" (0+ " ")
(group (regexp ,org-ql-regexp-ts-active))))
"Matches DEADLINE keyword with a time-and-hour stamp, with or without time.")
(defvar org-ql-regexp-deadline-with-time
(rx-to-string `(seq bow "DEADLINE" ":" (0+ " ")
(group (regexp ,org-ql-regexp-ts-active-with-time))))
"Matches DEADLINE keyword with a time-and-hour stamp, with time.")
(defvar org-ql-regexp-deadline-without-time
(rx-to-string `(seq bow "DEADLINE" ":" (0+ " ")
(group (regexp ,org-ql-regexp-ts-active-without-time))))
"Matches DEADLINE keyword with a time-and-hour stamp, without time.")
(defvar org-ql-regexp-scheduled (defvar org-ql-regexp-scheduled
(rx-to-string `(seq bow "SCHEDULED" ":" (0+ " ") (rx-to-string `(seq bow "SCHEDULED" ":" (0+ " ")
(group (regexp ,org-ql-regexp-ts-both)))) (group (regexp ,org-ql-regexp-ts-active))))
"Matches SCHEDULED keyword with a time-and-hour stamp, with or without time.") "Matches SCHEDULED keyword with a time-and-hour stamp, with or without time.")
(defvar org-ql-regexp-scheduled-with-time (defvar org-ql-regexp-scheduled-with-time
(rx-to-string `(seq bow "SCHEDULED" ":" (0+ " ") (rx-to-string `(seq bow "SCHEDULED" ":" (0+ " ")
(group (regexp ,org-ql-regexp-ts-both-with-time)))) (group (regexp ,org-ql-regexp-ts-active-with-time))))
"Matches SCHEDULED keyword with a time-and-hour stamp, with time.") "Matches SCHEDULED keyword with a time-and-hour stamp, with time.")
(defvar org-ql-regexp-scheduled-without-time (defvar org-ql-regexp-scheduled-without-time
(rx-to-string `(seq bow "SCHEDULED" ":" (0+ " ") (rx-to-string `(seq bow "SCHEDULED" ":" (0+ " ")
(group (regexp ,org-ql-regexp-ts-both-without-time)))) (group (regexp ,org-ql-regexp-ts-active-without-time))))
"Matches SCHEDULED keyword with a time-and-hour stamp, without time.") "Matches SCHEDULED keyword with a time-and-hour stamp, without time.")
;;;; Customization ;;;; Customization
@ -742,25 +784,34 @@ Arguments STRING, POS, FILL, and LEVEL are according to
(let ((byte-compile-log-warning-function #'org-ql--byte-compile-warning)) (let ((byte-compile-log-warning-function #'org-ql--byte-compile-warning))
(byte-compile (byte-compile
`(lambda () `(lambda ()
;; NOTE: `clocked' and `closed' don't have WITH-TIME args, because they should always have a time.
;; TODO: If possible, all of this argument processing should be done in each predicate's normalizers.
(cl-macrolet ((clocked (&key from to on) (cl-macrolet ((clocked (&key from to on)
(org-ql--from-to-on) (org-ql--from-to-on)
`(org-ql--predicate-clocked :from ,from :to ,to)) `(org-ql--predicate-clocked :from ,from :to ,to))
(closed (&key from to on (with-time 'not-found)) (closed (&key from to on (with-time 'not-found))
(org-ql--from-to-on) (org-ql--from-to-on)
`(org-ql--predicate-closed :from ,from :to ,to :with-time ,with-time)) `(org-ql--predicate-closed :from ,from :to ,to))
(deadline (&key from to on (with-time 'not-found)) (deadline (&key from to on (with-time 'not-found))
(org-ql--from-to-on) (org-ql--from-to-on)
`(org-ql--predicate-deadline :from ,from :to ,to :with-time ,with-time)) `(org-ql--predicate-deadline
:from ,from :to ,to :with-time ',with-time
:regexp ,(pcase-exhaustive with-time
('t org-ql-regexp-deadline-with-time)
('nil org-ql-regexp-deadline-without-time)
('not-found org-ql-regexp-deadline))))
(planning (&key from to on (with-time 'not-found)) (planning (&key from to on (with-time 'not-found))
(org-ql--from-to-on) (org-ql--from-to-on)
`(org-ql--predicate-planning :from ,from :to ,to :with-time ',with-time `(org-ql--predicate-planning
:from ,from :to ,to :with-time ',with-time
:regexp ,(pcase-exhaustive with-time :regexp ,(pcase-exhaustive with-time
('t org-ql-regexp-planning-with-time) ('t org-ql-regexp-planning-with-time)
('nil org-ql-regexp-planning-without-time) ('nil org-ql-regexp-planning-without-time)
('not-found org-ql-regexp-planning)))) ('not-found org-ql-regexp-planning))))
(scheduled (&key from to on (with-time 'not-found)) (scheduled (&key from to on (with-time 'not-found))
(org-ql--from-to-on) (org-ql--from-to-on)
`(org-ql--predicate-scheduled :from ,from :to ,to :with-time ',with-time `(org-ql--predicate-scheduled
:from ,from :to ,to :with-time ',with-time
:regexp ,(pcase-exhaustive with-time :regexp ,(pcase-exhaustive with-time
('t org-ql-regexp-scheduled-with-time) ('t org-ql-regexp-scheduled-with-time)
('nil org-ql-regexp-scheduled-without-time) ('nil org-ql-regexp-scheduled-without-time)
@ -1837,6 +1888,7 @@ parseable by `parse-time-string' which may omit the time value."
(org-ql--predicate-ts :from from :to to :regexp org-ql-clock-regexp :match-group 1)) (org-ql--predicate-ts :from from :to to :regexp org-ql-clock-regexp :match-group 1))
(org-ql-defpred closed (&key from to _on) (org-ql-defpred closed (&key from to _on)
;; TODO: Should this use the new org-ql-regexps?
;; The underscore before `on' prevents "unused lexical variable" ;; The underscore before `on' prevents "unused lexical variable"
;; warnings, because we pre-process that argument in a macro before ;; warnings, because we pre-process that argument in a macro before
;; this function is called. ;; this function is called.
@ -1866,7 +1918,7 @@ parseable by `parse-time-string' which may omit the time value."
(org-ql--predicate-ts :from from :to to :regexp org-closed-time-regexp :match-group 1 (org-ql--predicate-ts :from from :to to :regexp org-closed-time-regexp :match-group 1
:limit (line-end-position 2))) :limit (line-end-position 2)))
(org-ql-defpred deadline (&key from to _on) (org-ql-defpred deadline (&key from to _on regexp _with-time)
;; The underscore before `on' prevents "unused lexical variable" ;; The underscore before `on' prevents "unused lexical variable"
;; warnings, because we pre-process that argument in a macro before ;; warnings, because we pre-process that argument in a macro before
;; this function is called. ;; this function is called.
@ -1895,13 +1947,19 @@ parseable by `parse-time-string' which may omit the time value."
(ts-apply :hour 23 :minute 59 :second 59)))) (ts-apply :hour 23 :minute 59 :second 59))))
`(deadline :to ,to)))) `(deadline :to ,to))))
;; NOTE: Does this normalizer cause the preamble to not be used? (Adding one to the deadline-warning definition to be sure.) ;; NOTE: Does this normalizer cause the preamble to not be used? (Adding one to the deadline-warning definition to be sure.)
:preambles ((`(,predicate-names . ,_) :preambles ((`(,predicate-names . ,rest)
(list :regexp org-deadline-time-regexp :query query))) (list :query query
:regexp (pcase-exhaustive (org-ql--plist-get* rest :with-time)
('t org-ql-regexp-deadline-with-time)
('nil org-ql-regexp-deadline-without-time)
('not-found org-ql-regexp-deadline)))))
:body :body
(org-ql--predicate-ts :from from :to to :regexp org-deadline-time-regexp :match-group 1 (org-ql--predicate-ts :from from :to to :regexp regexp :match-group 1
:limit (line-end-position 2))) :limit (line-end-position 2)))
(org-ql-defpred deadline-warning (&key from to) (org-ql-defpred deadline-warning (&key from to)
;; TODO: Should this also accept a WITH-TIME argument?
;; TODO: Should this use the new org-ql-regexps?
"Internal selector used to handle `org-deadline-warning-days' and deadlines with warning periods." "Internal selector used to handle `org-deadline-warning-days' and deadlines with warning periods."
:preambles ((`(,predicate-names . ,_) :preambles ((`(,predicate-names . ,_)
(list :regexp org-deadline-time-regexp :query query))) (list :regexp org-deadline-time-regexp :query query)))
@ -1964,7 +2022,7 @@ parseable by `parse-time-string' which may omit the time value."
(org-ql--predicate-ts :from from :to to :match-group 1 :limit (line-end-position 2) (org-ql--predicate-ts :from from :to to :match-group 1 :limit (line-end-position 2)
:regexp regexp)) :regexp regexp))
(org-ql-defpred scheduled (&key from to _on regexp with-time) (org-ql-defpred scheduled (&key from to _on regexp _with-time)
;; The underscore before `on' prevents "unused lexical variable" ;; The underscore before `on' prevents "unused lexical variable"
;; warnings, because we pre-process that argument in a macro before ;; warnings, because we pre-process that argument in a macro before
;; this function is called. ;; this function is called.

View file

@ -43,7 +43,7 @@ SCHEDULED: <2017-07-05 Wed +2d>
:END: :END:
** TODO [#B] Renew membership in supervillain club ** TODO [#B] Renew membership in supervillain club
DEADLINE: <2017-07-10 Mon -1w> DEADLINE: <2017-07-10 Mon 23:59 -1w>
** DONE [#B] Learn universal sign language ** DONE [#B] Learn universal sign language
CLOSED: [2017-07-05 Wed 03:02] CLOSED: [2017-07-05 Wed 03:02]

View file

@ -637,7 +637,15 @@ RESULTS should be a list of strings as returned by
'("Take over the universe" "Take over the world" "Visit Mars" "Visit the moon" "Renew membership in supervillain club" "Internet" "Spaceship lease" "/r/emacs")) '("Take over the universe" "Take over the world" "Visit Mars" "Visit the moon" "Renew membership in supervillain club" "Internet" "Spaceship lease" "/r/emacs"))
(org-ql-then (org-ql-then
(org-ql-expect ('(deadline :to today)) (org-ql-expect ('(deadline :to today))
'("/r/emacs"))))) '("/r/emacs"))))
(org-ql-it ":with-time"
(org-ql-expect ('(deadline :with-time nil))
'("Take over the universe" "Take over the world" "Visit Mars" "Visit the moon" "Internet" "Spaceship lease" "/r/emacs"))
(org-ql-expect ('(deadline :with-time t))
'("Renew membership in supervillain club"))
(org-ql-expect ('(deadline :to "2017-07-10" :with-time t))
'("Renew membership in supervillain club"))))
(org-ql-it "(done)" (org-ql-it "(done)"
(org-ql-expect ('(done)) (org-ql-expect ('(done))
@ -835,9 +843,9 @@ RESULTS should be a list of strings as returned by
(org-ql-it ":with-time" (org-ql-it ":with-time"
(org-ql-expect ('(planning :with-time nil)) (org-ql-expect ('(planning :with-time nil))
'("Take over the universe" "Take over the world" "Visit Mars" "Visit the moon" "Practice leaping tall buildings in a single bound" "Renew membership in supervillain club" "Get haircut" "Internet" "Spaceship lease" "Fix flux capacitor" "/r/emacs" "Shop for groceries" "Rewrite Emacs in Common Lisp")) '("Take over the universe" "Take over the world" "Visit Mars" "Visit the moon" "Practice leaping tall buildings in a single bound" "Get haircut" "Internet" "Spaceship lease" "Fix flux capacitor" "/r/emacs" "Shop for groceries" "Rewrite Emacs in Common Lisp"))
(org-ql-expect ('(planning :with-time t)) (org-ql-expect ('(planning :with-time t))
'("Skype with president of Antarctica" "Learn universal sign language" "Order a pizza")) '("Skype with president of Antarctica" "Renew membership in supervillain club" "Learn universal sign language" "Order a pizza"))
(org-ql-expect ('(planning :to "2017-07-04" :with-time t)) (org-ql-expect ('(planning :to "2017-07-04" :with-time t))
'("Skype with president of Antarctica")))) '("Skype with president of Antarctica"))))
@ -1158,9 +1166,9 @@ RESULTS should be a list of strings as returned by
(org-ql-it ":with-time" (org-ql-it ":with-time"
(org-ql-expect ('(ts-active :with-time nil)) (org-ql-expect ('(ts-active :with-time nil))
'("Take over the universe" "Take over the world" "Visit Mars" "Visit the moon" "Practice leaping tall buildings in a single bound" "Renew membership in supervillain club" "Get haircut" "Internet" "Spaceship lease" "Fix flux capacitor" "/r/emacs" "Shop for groceries" "Rewrite Emacs in Common Lisp")) '("Take over the universe" "Take over the world" "Visit Mars" "Visit the moon" "Practice leaping tall buildings in a single bound" "Get haircut" "Internet" "Spaceship lease" "Fix flux capacitor" "/r/emacs" "Shop for groceries" "Rewrite Emacs in Common Lisp"))
(org-ql-expect ('(ts-active :with-time t)) (org-ql-expect ('(ts-active :with-time t))
'("Skype with president of Antarctica" "Order a pizza")) '("Skype with president of Antarctica" "Renew membership in supervillain club" "Order a pizza"))
(org-ql-expect ('(ts-active :to "2017-07-04" :with-time t)) (org-ql-expect ('(ts-active :to "2017-07-04" :with-time t))
'("Skype with president of Antarctica")))) '("Skype with president of Antarctica"))))
@ -1284,9 +1292,9 @@ RESULTS should be a list of strings as returned by
(org-ql-it ":with-time" (org-ql-it ":with-time"
(org-ql-expect ('(ts :with-time nil)) (org-ql-expect ('(ts :with-time nil))
'("Take over the universe" "Take over the world" "Visit Mars" "Visit the moon" "Practice leaping tall buildings in a single bound" "Renew membership in supervillain club" "Get haircut" "Internet" "Spaceship lease" "Fix flux capacitor" "/r/emacs" "Shop for groceries" "Rewrite Emacs in Common Lisp")) '("Take over the universe" "Take over the world" "Visit Mars" "Visit the moon" "Practice leaping tall buildings in a single bound" "Get haircut" "Internet" "Spaceship lease" "Fix flux capacitor" "/r/emacs" "Shop for groceries" "Rewrite Emacs in Common Lisp"))
(org-ql-expect ('(ts :with-time t)) (org-ql-expect ('(ts :with-time t))
'("Skype with president of Antarctica" "Visit the moon" "Learn universal sign language" "Order a pizza" "Rewrite Emacs in Common Lisp")) '("Skype with president of Antarctica" "Visit the moon" "Renew membership in supervillain club" "Learn universal sign language" "Order a pizza" "Rewrite Emacs in Common Lisp"))
(org-ql-expect ('(ts :to "2017-07-04" :with-time t)) (org-ql-expect ('(ts :to "2017-07-04" :with-time t))
'("Skype with president of Antarctica"))))) '("Skype with president of Antarctica")))))