From mboxrd@z Thu Jan 1 00:00:00 1970 From: Jesse Johnson Subject: Re: inherit priority Date: Mon, 9 Jul 2018 22:03:12 -0700 Message-ID: <01c7db31-72eb-be93-c772-e93b0327a906@gmail.com> References: <87wp0ymxgy.fsf@nicolasgoaziou.fr> <92a7a7a4-a992-86f5-eb8f-2381213ad32f@gmail.com> <87o9mam43l.fsf@nicolasgoaziou.fr> <87bme5pmnf.fsf@bzg.fr> <7e082452-7450-c2fa-ac53-40d75b348b3c@gmail.com> <87tvrxz9wx.fsf@gnu.org> <3e785a53-293d-0faf-d3b0-86036ebd1747@gmail.com> <87a7r0ked5.fsf@nicolasgoaziou.fr> Mime-Version: 1.0 Content-Type: text/plain; charset=utf-8; format=flowed Content-Transfer-Encoding: 8bit Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:52670) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1fcko6-0003Hl-OL for emacs-orgmode@gnu.org; Tue, 10 Jul 2018 01:03:26 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1fcko3-0003eg-PV for emacs-orgmode@gnu.org; Tue, 10 Jul 2018 01:03:22 -0400 In-Reply-To: <87a7r0ked5.fsf@nicolasgoaziou.fr> Content-Language: en-US List-Id: "General discussions about Org-mode." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-orgmode-bounces+geo-emacs-orgmode=m.gmane.org@gnu.org Sender: "Emacs-orgmode" To: Nicolas Goaziou Cc: Bastien , emacs-orgmode@gnu.org 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 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