Hi Nicolas,
On 07/09/2018 01:22 AM, Nicolas Goaziou wrote:
It looks good. Could you send it on this ML as a patch so I can comment
it more conveniently?
Since you want to comment I guess you want the patch in the e-mail body
rather than attached. Here goes nothing.
From bb02cd6c00b32155c0a25f409f1bfa4160b2ddcd Mon Sep 17 00:00:00 2001
From: Jesse Johnson <holocronwea...@gmail.com>
Date: Sun, 22 Apr 2018 18:12:54 -0700
Subject: [PATCH] Add priority inheritance
* New org-use-priority-inheritance defcustom to toggle inheritance.
* org-get-priority now takes a pos and implements inheritance.
* org-get-priority-function can make use of inheritance by returning t.
* org-agenda-fix-displayed-priority ensures inherited priority is
visible.
* Updates where priority is used so that inheritance is respected. As
a side effect, org-get-priority-function is now more widely
respected.
---
lisp/org-agenda.el | 117
+++++++++++++++++++++++++++++++++--------------------
lisp/org-habit.el | 16 ++++----
lisp/org.el | 102 ++++++++++++++++++++++++++++++++++------------
3 files changed, 157 insertions(+), 78 deletions(-)
diff --git a/lisp/org-agenda.el b/lisp/org-agenda.el
index eaeddb6..e18e73d 100644
--- a/lisp/org-agenda.el
+++ b/lisp/org-agenda.el
@@ -4581,6 +4581,7 @@ is active."
(setq marker (org-agenda-new-marker (point))
category (org-get-category)
level (make-string (org-reduced-level
(org-outline-level)) ? )
+ priority (org-get-priority)
inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
@@ -4593,13 +4594,13 @@ is active."
""
(buffer-substring-no-properties
beg1 (point-at-eol))
- level category tags t))
+ level category priority tags t))
(org-add-props txt props
'org-marker marker 'org-hd-marker marker
'org-todo-regexp org-todo-regexp
'level level
'org-complex-heading-regexp org-complex-heading-regexp
- 'priority 1000
+ 'priority priority
'type "search")
(push txt ee)
(goto-char (1- end))))))))))
@@ -5078,7 +5079,7 @@ of what a project is and how to check if it stuck,
customize the variable
(setq entries
(mapcar
(lambda (x)
- (setq x (org-agenda-format-item "" x nil "Diary" nil 'time))
+ (setq x (org-agenda-format-item "" x nil "Diary" nil nil 'time))
;; Extend the text properties to the beginning of the line
(org-add-props x (text-properties-at (1- (length x)) x)
'type "diary" 'date date 'face 'org-agenda-diary))
@@ -5361,6 +5362,7 @@ and the timestamp type relevant for the sorting
strategy in
ts-date (car ts-date-pair)
ts-date-type (cdr ts-date-pair)
txt (org-trim (buffer-substring (match-beginning 2)
(match-end 0)))
+ priority (1+ (org-get-priority))
inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
@@ -5370,8 +5372,7 @@ and the timestamp type relevant for the sorting
strategy in
(memq 'todo org-agenda-use-tag-inheritance))))
tags (org-get-tags nil (not inherited-tags))
level (make-string (org-reduced-level (org-outline-level)) ? )
- txt (org-agenda-format-item "" txt level category tags t)
- priority (1+ (org-get-priority txt)))
+ txt (org-agenda-format-item "" txt level category priority
tags t))
(org-add-props txt props
'org-marker marker 'org-hd-marker marker
'priority priority
@@ -5570,6 +5571,9 @@ displayed in agenda view."
(assq (point) deadline-position-alist))
(throw :skip nil))
(let* ((category (org-get-category pos))
+ (priority (if habit?
+ (org-habit-get-priority
(org-habit-parse-todo))
+ (org-get-priority item)))
(inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (consp org-agenda-show-inherited-tags)
@@ -5588,11 +5592,10 @@ displayed in agenda view."
(item
(org-agenda-format-item
(and inactive? org-agenda-inactive-leader)
- head level category tags time-stamp org-ts-regexp habit?)))
+ head level category priority tags
+ time-stamp org-ts-regexp habit?)))
(org-add-props item props
- 'priority (if habit?
- (org-habit-get-priority (org-habit-parse-todo))
- (org-get-priority item))
+ 'priority priority
'org-marker (org-agenda-new-marker pos)
'org-hd-marker (org-agenda-new-marker)
'date date
@@ -5635,6 +5638,7 @@ displayed in agenda view."
(setq marker (org-agenda-new-marker beg)
level (make-string (org-reduced-level (org-outline-level)) ? )
category (org-get-category beg)
+ priority (org-get-priority)
inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
@@ -5657,7 +5661,7 @@ displayed in agenda view."
(if (string-match "\\S-" r)
(setq txt r)
(setq txt "SEXP entry returned empty string"))
- (setq txt (org-agenda-format-item extra txt level category tags
'time))
+ (setq txt (org-agenda-format-item extra txt level category
priority tags 'time))
(org-add-props txt props 'org-marker marker
'date date 'todo-state todo-state
'level level 'type "sexp" 'warntime warntime)
@@ -5785,6 +5789,7 @@ then those holidays will be skipped."
(throw :skip nil)
(goto-char (match-beginning 0))
(setq hdmarker (org-agenda-new-marker)
+ priority (org-get-priority)
inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
@@ -5806,8 +5811,7 @@ then those holidays will be skipped."
(closedp "Closed: ")
(statep (concat "State: (" state ")"))
(t (concat "Clocked: (" clocked ")")))
- txt level category tags timestr)))
- (setq priority 100000)
+ txt level category priority tags timestr)))
(org-add-props txt props
'org-marker marker 'org-hd-marker hdmarker 'face 'org-agenda-done
'priority priority 'level level
@@ -6032,6 +6036,13 @@ specification like [h]h:mm."
(level (make-string (org-reduced-level (org-outline-level))
?\s))
(head (buffer-substring (point) (line-end-position)))
+ (priority
+ ;; Adjust priority to today reminders about deadlines.
+ ;; Overdue deadlines get the highest priority
+ ;; increase, then imminent deadlines and eventually
+ ;; more distant deadlines.
+ (let ((adjust (if today? (- diff) 0)))
+ (+ adjust (org-get-priority))))
(inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
@@ -6059,7 +6070,7 @@ specification like [h]h:mm."
((and today? (< deadline today)) (format past (- diff)))
((and today? (> deadline today)) (format future diff))
(t now)))
- head level category tags time))
+ head level category priority tags time))
(face (org-agenda-deadline-face
(- 1 (/ (float diff) (max wdays 1)))))
(upcoming? (and today? (> deadline today)))
@@ -6070,13 +6081,7 @@ specification like [h]h:mm."
'warntime warntime
'level level
'ts-date deadline
- 'priority
- ;; Adjust priority to today reminders about deadlines.
- ;; Overdue deadlines get the highest priority
- ;; increase, then imminent deadlines and eventually
- ;; more distant deadlines.
- (let ((adjust (if today? (- diff) 0)))
- (+ adjust (org-get-priority item)))
+ 'priority priority
'todo-state todo-state
'type (if upcoming? "upcoming-deadline" "deadline")
'date (if upcoming? date deadline)
@@ -6222,16 +6227,19 @@ scheduled items with an hour specification like
[h]h:mm."
;; Skip habits if `org-habit-show-habits' is nil, or if we
;; only show them for today. Also skip done habits.
(when (and habitp
- (or donep
- (not (bound-and-true-p org-habit-show-habits))
- (and (not todayp)
- (bound-and-true-p
- org-habit-show-habits-only-for-today))))
+ (or donep
+ (not (bound-and-true-p org-habit-show-habits))
+ (and (not todayp)
+ (bound-and-true-p
+ org-habit-show-habits-only-for-today))))
(throw :skip nil))
(save-excursion
(re-search-backward "^\\*+[ \t]+" nil t)
(goto-char (match-end 0))
(let* ((category (org-get-category))
+ (habit (and habitp (org-habit-parse-todo)))
+ (priority (if habit (org-habit-get-priority habit)
+ (+ 99 diff (org-get-priority))))
(inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
@@ -6259,12 +6267,11 @@ scheduled items with an hour specification like
[h]h:mm."
(if (and todayp pastschedp)
(format past diff)
first))
- head level category tags time nil habitp))
+ head level category priority tags time nil habitp))
(face (cond ((and (not habitp) pastschedp)
'org-scheduled-previously)
(todayp 'org-scheduled-today)
- (t 'org-scheduled)))
- (habitp (and habitp (org-habit-parse-todo))))
+ (t 'org-scheduled))))
(org-add-props item props
'undone-face face
'face (if donep 'org-agenda-done face)
@@ -6275,9 +6282,8 @@ scheduled items with an hour specification like
[h]h:mm."
'ts-date schedule
'warntime warntime
'level level
- 'priority (if habitp (org-habit-get-priority habitp)
- (+ 99 diff (org-get-priority item)))
- 'org-habit-p habitp
+ 'priority priority
+ 'org-habit-p habit
'todo-state todo-state)
(push item scheduled-items))))))
(nreverse scheduled-items)))
@@ -6295,7 +6301,7 @@ scheduled items with an hour specification like
[h]h:mm."
(regexp org-tr-regexp)
(d0 (calendar-absolute-from-gregorian date))
marker hdmarker ee txt d1 d2 s1 s2 category
- level todo-state tags pos head donep inherited-tags)
+ level priority todo-state tags pos head donep inherited-tags)
(goto-char (point-min))
(while (re-search-forward regexp nil t)
(catch :skip
@@ -6346,7 +6352,7 @@ scheduled items with an hour specification like
[h]h:mm."
(and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t)
(memq 'agenda org-agenda-use-tag-inheritance))))
-
+ priority (org-get-priority)
tags (org-get-tags nil (not inherited-tags)))
(setq level (make-string (org-reduced-level
(org-outline-level)) ? ))
(looking-at "\\*+[ \t]+\\(.*\\)")
@@ -6363,7 +6369,7 @@ scheduled items with an hour specification like
[h]h:mm."
(nth (if (= d1 d2) 0 1)
org-agenda-timerange-leaders)
(1+ (- d0 d1)) (1+ (- d2 d1)))
- head level category tags
+ head level category priority tags
(cond ((and (= d1 d0) (= d2 d0))
(concat "<" start-time ">--<" end-time ">"))
((= d1 d0)
@@ -6376,11 +6382,11 @@ scheduled items with an hour specification like
[h]h:mm."
'type "block" 'date date
'level level
'todo-state todo-state
- 'priority (org-get-priority txt))
+ 'priority priority)
(push txt ee))))
- (goto-char pos)))
- ;; Sort the entries by expiration date.
- (nreverse ee)))
+ (goto-char pos)))
+ ;; Sort the entries by expiration date.
+ (nreverse ee)))
;;; Agenda presentation and sorting
@@ -6409,8 +6415,9 @@ The flag is set if the currently compiled format
contains a `%b'.")
(cl-return (cadr entry))
(cl-return (apply #'create-image (cdr entry)))))))
-(defun org-agenda-format-item (extra txt &optional level category tags
dotime
- remove-re habitp)
+(defun org-agenda-format-item (extra txt
+ &optional level category priority tags
+ dotime remove-re habitp)
"Format TXT to be inserted into the agenda buffer.
In particular, add the prefix and corresponding text properties.
@@ -6419,10 +6426,11 @@ LEVEL may be a string to replace the `%l' specifier.
CATEGORY (a string, a symbol or nil) may be used to overrule the default
category taken from local variable or file name. It will replace the `%c'
specifier in the format.
+PRIORITY can be the integer priority of the headline.
+TAGS can be the tags of the headline.
DOTIME, when non-nil, indicates that a time-of-day should be extracted
from
TXT for sorting of this entry, and for the `%t' specifier in the format.
When DOTIME is a string, this string is searched for a time before TXT is.
-TAGS can be the tags of the headline.
Any match of REMOVE-RE will be removed from TXT."
;; We keep the org-prefix-* variable values along with a compiled
;; formatter, so that multiple agendas existing at the same time do
@@ -6440,6 +6448,9 @@ Any match of REMOVE-RE will be removed from TXT."
;; Diary entries sometimes have extra whitespace at the beginning
(setq txt (org-trim txt))
+ ;; Fix the priority part in txt
+ (setq txt (org-agenda-fix-displayed-priority txt priority))
+
;; Fix the tags part in txt
(setq txt (org-agenda-fix-displayed-tags
txt tags
@@ -6611,6 +6622,20 @@ The modified list may contain inherited tags, and
tags matched by
(if have-i "::" ":"))))))
txt)
+(defun org-agenda-fix-displayed-priority (txt priority)
+ "Modifies TXT to show correct PRIORITY.
+Respects `org-use-priority-inheritance' by adding PRIORITY if not
+already present. No change is made if `org-get-priority-function'
+is non-nil since TXT may be using non-standard priority cookies."
+ (when (and priority
+ org-use-priority-inheritance
+ (not (functionp org-get-priority-function))
+ (not (string-match org-priority-regexp txt)))
+ (let ((priority-str
+ (char-to-string (org-priority-integer-to-char priority))))
+ (setq txt (concat "[#" priority-str "] " txt))))
+ txt)
+
(defun org-downcase-keep-props (s)
(let ((props (text-properties-at 0 s)))
(setq s (downcase s))
@@ -6646,14 +6671,14 @@ TODAYP is t when the current agenda view is on
today."
(unless (and remove (member time have))
(setq time (replace-regexp-in-string " " "0" (format "%04s" time)))
(push (org-agenda-format-item
- nil string nil "" nil
+ nil string nil "" nil nil nil
(concat (substring time 0 -2) ":" (substring time -2)))
new)
(put-text-property
2 (length (car new)) 'face 'org-time-grid (car new))))
(when (and todayp org-agenda-show-current-time-in-grid)
(push (org-agenda-format-item
- nil org-agenda-current-time-string nil "" nil
+ nil org-agenda-current-time-string nil "" nil nil nil
(format-time-string "%H:%M "))
new)
(put-text-property
@@ -8932,6 +8957,10 @@ If FORCE-TAGS is non nil, the car of it returns
the new tags."
(let* ((inhibit-read-only t)
(line (org-current-line))
(org-agenda-buffer (current-buffer))
+ (priority (with-current-buffer (marker-buffer hdmarker)
+ (org-with-wide-buffer
+ (goto-char hdmarker)
+ (org-get-priority))))
(thetags (with-current-buffer (marker-buffer hdmarker)
(org-get-tags hdmarker)))
props m pl undone-face done-face finish new dotime level cat tags)
@@ -8955,7 +8984,7 @@ If FORCE-TAGS is non nil, the car of it returns
the new tags."
(extra (org-get-at-bol 'extra)))
(with-current-buffer (marker-buffer hdmarker)
(org-with-wide-buffer
- (org-agenda-format-item extra newhead level cat tags
dotime))))
+ (org-agenda-format-item extra newhead level cat priority
tags dotime))))
pl (text-property-any (point-at-bol) (point-at-eol)
'org-heading t)
undone-face (org-get-at-bol 'undone-face)
done-face (org-get-at-bol 'done-face))
diff --git a/lisp/org-habit.el b/lisp/org-habit.el
index 375714e..2d5d0d8 100644
--- a/lisp/org-habit.el
+++ b/lisp/org-habit.el
@@ -248,23 +248,23 @@ This list represents a \"habit\" for the rest of
this module."
(defsubst org-habit-get-priority (habit &optional moment)
"Determine the relative priority of a habit.
This must take into account not just urgency, but consistency as well."
- (let ((pri 1000)
- (now (if moment (time-to-days moment) (org-today)))
- (scheduled (org-habit-scheduled habit))
- (deadline (org-habit-deadline habit)))
+ (let ((pri (org-get-priority))
+ (now (if moment (time-to-days moment) (org-today)))
+ (scheduled (org-habit-scheduled habit))
+ (deadline (org-habit-deadline habit)))
;; add 10 for every day past the scheduled date, and subtract for
every
;; day before it
(setq pri (+ pri (* (- now scheduled) 10)))
;; add 50 if the deadline is today
(if (and (/= scheduled deadline)
- (= now deadline))
- (setq pri (+ pri 50)))
+ (= now deadline))
+ (setq pri (+ pri 50)))
;; add 100 for every day beyond the deadline date, and subtract 10 for
;; every day before it
(let ((slip (- now (1- deadline))))
(if (> slip 0)
- (setq pri (+ pri (* slip 100)))
- (setq pri (+ pri (* slip 10)))))
+ (setq pri (+ pri (* slip 100)))
+ (setq pri (+ pri (* slip 10)))))
pri))
(defun org-habit-get-faces (habit &optional now-days scheduled-days donep)
diff --git a/lisp/org.el b/lisp/org.el
index 66eb2f3..768b84a 100644
--- a/lisp/org.el
+++ b/lisp/org.el
@@ -3175,18 +3175,46 @@ See also `org-default-priority'."
:type 'boolean)
(defcustom org-get-priority-function nil
- "Function to extract the priority from a string.
-The string is normally the headline. If this is nil Org computes the
-priority from the priority cookie like [#A] in the headline. It returns
-an integer, increasing by 1000 for each priority level.
-The user can set a different function here, which should take a string
-as an argument and return the numeric priority."
+ "Function to extract the priority from current line.
+The line is always a headline.
+
+If this is nil Org computes the priority of the headline from a
+priority cookie like [#A]. It returns an integer, increasing by
+1000 for each priority level (see
+`org-priority-char-to-integer').
+
+The user can set a different function here, which should process
+the current line and return one of:
+
+- an integer priority
+- nil if current line is not a header or otherwise has no
+associated priority
+- t if the `org-default-priority' should be used or the priority can be
+inherited from its parent
+
+Priority can only be inherited if `org-use-priority-inheritance' is
+non-nil."
:group 'org-priorities
:version "24.1"
:type '(choice
(const nil)
(function)))
+(defcustom org-use-priority-inheritance nil
+ "Whether headline priority is inherited from its parents.
+
+If non-nil then the first explicit priority found when searching
+up the headline tree applies. Thus a child headline can override
+its parent's priority.
+
+When nil, explicit priorities only apply to the headline they are
+given on.
+
+Regardless of setting, if no explicit priority is found then the
+default priority is used."
+ :group 'org-priorities
+ :type 'boolean)
+
(defgroup org-time nil
"Options concerning time stamps and deadlines in Org mode."
:tag "Org Time"
@@ -13633,22 +13661,43 @@ and by additional input from the age of a
schedules or deadline entry."
(interactive)
(let ((pri (if (eq major-mode 'org-agenda-mode)
(org-get-at-bol 'priority)
- (save-excursion
- (save-match-data
- (beginning-of-line)
- (and (looking-at org-heading-regexp)
- (org-get-priority (match-string 0))))))))
+ (org-get-priority))))
(message "Priority is %d" (if pri pri -1000))))
-(defun org-get-priority (s)
- "Find priority cookie and return priority."
- (save-match-data
- (if (functionp org-get-priority-function)
- (funcall org-get-priority-function)
- (if (not (string-match org-priority-regexp s))
- (* 1000 (- org-lowest-priority org-default-priority))
- (* 1000 (- org-lowest-priority
- (string-to-char (match-string 2 s))))))))
+(defun org-priority-char-to-integer (character)
+ "Convert priority CHARACTER to an integer priority."
+ (* 1000 (- org-lowest-priority character)))
+
+(defun org-priority-integer-to-char (integer)
+ "Convert priority INTEGER to a character priority."
+ (- org-lowest-priority (/ integer 1000)))
+
+(defun org-get-priority (&optional pos local)
+ "Get integer priority at POS.
+POS defaults to point. If LOCAL is non-nil priority inheritance
+is ignored regardless of the value of
+`org-use-priority-inheritance'. Returns nil if no priority can be
+determined at POS."
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (or pos (point)))
+ (beginning-of-line)
+ (if (not (looking-at org-heading-regexp))
+ (return nil)
+ (save-match-data
+ (cl-loop
+ (if (functionp org-get-priority-function)
+ (let ((priority (funcall org-get-priority-function)))
+ (unless (eq priority t)
+ (return priority)))
+ (when (looking-at org-priority-regexp)
+ (return (org-priority-char-to-integer
+ (string-to-char (match-string-no-properties 2))))))
+ (unless (and (not local)
+ org-use-priority-inheritance
+ (org-up-heading-safe))
+ (return (org-priority-char-to-integer
org-default-priority)))))))))
;;;; Tags
@@ -13713,6 +13762,7 @@ headlines matching this string."
(or (buffer-file-name (buffer-base-buffer))
(buffer-name (buffer-base-buffer)))))))
(org-map-continue-from nil)
+ priority
lspos tags tags-list
(tags-alist (list (cons 0 org-file-tags)))
(llast 0) rtn rtn1 level category i txt
@@ -13800,7 +13850,8 @@ headlines matching this string."
(match-beginning 1) (match-end 1)))
(org-show-context 'tags-tree))
((eq action 'agenda)
- (setq txt (org-agenda-format-item
+ (setq priority (org-get-priority)
+ txt (org-agenda-format-item
""
(concat
(if (eq org-tags-match-list-sublevels 'indented)
@@ -13808,8 +13859,8 @@ headlines matching this string."
(org-get-heading))
(make-string level ?\s)
category
- tags-list)
- priority (org-get-priority txt))
+ priority
+ tags-list))
(goto-char lspos)
(setq marker (org-agenda-new-marker))
(org-add-props txt props
@@ -15066,9 +15117,8 @@ strings."
(when specific (throw 'exit props)))
(when (or (not specific) (string= specific "PRIORITY"))
(push (cons "PRIORITY"
- (if (looking-at org-priority-regexp)
- (match-string-no-properties 2)
- (char-to-string org-default-priority)))
+ (char-to-string
+ (org-priority-integer-to-char
(org-get-priority))))
props)
(when specific (throw 'exit props)))
(when (or (not specific) (string= specific "FILE"))
--
2.7.4
