lisp/org-num.el

   1 ;;; org-num.el --- Dynamic Headlines Numbering  -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2018-2019  Free Software Foundation, Inc.
   4
   5 ;; Author: Nicolas Goaziou <mail@nicolasgoaziou.fr>
   6 ;; Keywords: outlines, hypermedia, calendar, wp
   7
   8 ;; This program is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation, either version 3 of the License, or
  11 ;; (at your option) any later version.
  12
  13 ;; This program is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
  20
  21 ;;; Commentary:
  22
  23 ;; This library provides dynamic numbering for Org headlines.  Use
  24 ;;
  25 ;;     <M-x org-num-mode>
  26 ;;
  27 ;; to toggle it.
  28 ;;
  29 ;; You can select what is numbered according to level, tags, COMMENT
  30 ;; keyword, or UNNUMBERED property. You can also skip footnotes
  31 ;; sections. See `org-num-max-level', `org-num-skip-tags',
  32 ;; `org-num-skip-commented', `org-num-skip-unnumbered', and
  33 ;; `org-num-skip-footnotes' for details.
  34 ;;
  35 ;; You can also control how the numbering is displayed by setting
  36 ;;`org-num-face' and `org-num-format-function'.
  37 ;;
  38 ;; Internally, the library handles an ordered list, per buffer
  39 ;; position, of overlays in `org-num--overlays'.  These overlays are
  40 ;; marked with the `org-num' property set to a non-nil value.
  41 ;;
  42 ;; Overlays store the level of the headline in the `level' property,
  43 ;; and the face used for the numbering in `numbering-face'.
  44 ;;
  45 ;; The `skip' property is set to t when the corresponding headline has
  46 ;; some characteristic -- e.g., a node property, or a tag -- that
  47 ;; prevents it from being numbered.
  48 ;;
  49 ;; An overlay with `org-num' property set to `invalid' is called an
  50 ;; invalid overlay.  Modified overlays automatically become invalid
  51 ;; and set `org-num--invalid-flag' to a non-nil value.  After
  52 ;; a change, `org-num--invalid-flag' indicates numbering needs to be
  53 ;; updated and invalid overlays indicate where the buffer needs to be
  54 ;; parsed.  So does `org-num--missing-overlay' variable.  See
  55 ;; `org-num--verify' function for details.
  56 ;;
  57 ;; Numbering display is done through the `after-string' property.
  58
  59 \f
  60 ;;; Code:
  61
  62 (require 'cl-lib)
  63 (require 'org-macs)
  64
  65 (defvar org-comment-string)
  66 (defvar org-complex-heading-regexp)
  67 (defvar org-cycle-level-faces)
  68 (defvar org-footnote-section)
  69 (defvar org-level-faces)
  70 (defvar org-n-level-faces)
  71 (defvar org-odd-levels-only)
  72
  73 (declare-function org-back-to-heading "org" (&optional invisible-ok))
  74 (declare-function org-entry-get "org" (pom property &optional inherit literal-nil))
  75 (declare-function org-reduced-level "org" (l))
  76
  77 \f
  78 ;;; Customization
  79
  80 (defcustom org-num-face nil
  81   "Face to use for numbering.
  82 When nil, use the same face as the headline.  This value is
  83 ignored if `org-num-format-function' specifies a face for its
  84 output."
  85   :group 'org-appearance
  86   :package-version '(Org . "9.3")
  87   :type '(choice (const :tag "Like the headline" nil)
  88                  (face :tag "Use face"))
  89   :safe (lambda (val) (or (null val) (facep val))))
  90
  91 (defcustom org-num-format-function 'org-num-default-format
  92   "Function used to display numbering.
  93 It is called with one argument, a list of numbers, and should
  94 return a string, or nil.  When nil, no numbering is displayed.
  95 Any `face' text property on the returned string overrides
  96 `org-num-face'."
  97   :group 'org-appearance
  98   :package-version '(Org . "9.3")
  99   :type 'function
 100   :safe nil)
 101
 102 (defcustom org-num-max-level nil
 103   "Level below which headlines are not numbered.
 104 When set to nil, all headlines are numbered."
 105   :group 'org-appearance
 106   :package-version '(Org . "9.3")
 107   :type '(choice (const :tag "Number everything" nil)
 108                  (integer :tag "Stop numbering at level"))
 109   :safe (lambda (val) (or (null val) (wholenump val))))
 110
 111 (defcustom org-num-skip-commented nil
 112   "Non-nil means commented sub-trees are not numbered."
 113   :group 'org-appearance
 114   :package-version '(Org . "9.3")
 115   :type 'boolean
 116   :safe #'booleanp)
 117
 118 (defcustom org-num-skip-footnotes nil
 119   "Non-nil means footnotes sections are not numbered."
 120   :group 'org-appearance
 121   :package-version '(Org . "9.3")
 122   :type 'boolean
 123   :safe #'booleanp)
 124
 125 (defcustom org-num-skip-tags nil
 126   "List of tags preventing the numbering of sub-trees.
 127
 128 For example, add \"ARCHIVE\" to this list to avoid numbering
 129 archived sub-trees.
 130
 131 Tag in this list prevent numbering the whole sub-tree,
 132 irrespective to `org-use-tags-inheritance', or other means to
 133 control tag inheritance."
 134   :group 'org-appearance
 135   :package-version '(Org . "9.3")
 136   :type '(repeat (string :tag "Tag"))
 137   :safe (lambda (val) (and (listp val) (cl-every #'stringp val))))
 138
 139 (defcustom org-num-skip-unnumbered nil
 140   "Non-nil means numbering obeys to UNNUMBERED property."
 141   :group 'org-appearance
 142   :package-version '(Org . "9.3")
 143   :type 'boolean
 144   :safe #'booleanp)
 145
 146 \f
 147 ;;; Internal Variables
 148
 149 (defconst org-num--comment-re (format "\\`%s\\(?: \\|$\\)" org-comment-string)
 150   "Regexp matching a COMMENT keyword at headline beginning.")
 151
 152 (defvar-local org-num--overlays nil
 153   "Ordered list of overlays used for numbering outlines.")
 154
 155 (defvar-local org-num--skip-level nil
 156   "Level below which headlines from current tree are not numbered.
 157 When nil, all headlines are numbered.  It is used to handle
 158 inheritance of no-numbering attributes.")
 159
 160 (defvar-local org-num--numbering nil
 161   "Current headline numbering.
 162 A numbering is a list of integers, in reverse order.  So numbering
 163 for headline \"1.2.3\" is (3 2 1).")
 164
 165 (defvar-local org-num--missing-overlay nil
 166   "Buffer position signaling a headline without an overlay.")
 167
 168 (defvar-local org-num--invalid-flag nil
 169   "Non-nil means an overlay became invalid since last update.")
 170
 171 \f
 172 ;;; Internal Functions
 173
 174 (defsubst org-num--headline-regexp ()
 175   "Return regexp matching a numbered headline."
 176   (if (null org-num-max-level) (org-with-limited-levels org-outline-regexp-bol)
 177     (format "^\\*\\{1,%d\\} "
 178             (if org-odd-levels-only (1- (* 2 org-num-max-level))
 179               org-num-max-level))))
 180
 181 (defsubst org-num--overlay-p (o)
 182   "Non-nil if overlay O is a numbering overlay."
 183   (overlay-get o 'org-num))
 184
 185 (defsubst org-num--valid-overlay-p (o)
 186   "Non-nil if overlay O is still active in the buffer."
 187   (not (eq 'invalid (overlay-get o 'org-num))))
 188
 189 (defsubst org-num--invalidate-overlay (o)
 190   "Mark overlay O as invalid.
 191 Update `org-num--invalid-flag' accordingly."
 192   (overlay-put o 'org-num 'invalid)
 193   (setq org-num--invalid-flag t))
 194
 195 (defun org-num--clear ()
 196   "Remove all numbering overlays in current buffer."
 197   (mapc #'delete-overlay org-num--overlays)
 198   (setq org-num--overlays nil))
 199
 200 (defun org-num--make-overlay (numbering level skip)
 201   "Return overlay for numbering headline at point.
 202
 203 NUMBERING is the numbering to use, as a list of integers, or nil
 204 if nothing should be displayed.  LEVEL is the level of the
 205 headline.  SKIP is its skip value.
 206
 207 Assume point is at a headline."
 208   (let ((after-edit-functions
 209          (list (lambda (o &rest _) (org-num--invalidate-overlay o))))
 210         (o (save-excursion
 211              (beginning-of-line)
 212              (skip-chars-forward "*")
 213              (make-overlay (line-beginning-position) (1+ (point))))))
 214     (overlay-put o 'org-num t)
 215     (overlay-put o 'skip skip)
 216     (overlay-put o 'level level)
 217     (overlay-put o 'numbering-face
 218                  (or org-num-face
 219                      ;; Compute face that would be used at the
 220                      ;; headline.  We cannot extract it from the
 221                      ;; buffer: at the time the overlay is created,
 222                      ;; Font Lock has not proceeded yet.
 223                      (nth (if org-cycle-level-faces
 224                               (% (1- level) org-n-level-faces)
 225                             (1- (min level org-n-level-faces)))
 226                           org-level-faces)))
 227     (overlay-put o 'modification-hooks after-edit-functions)
 228     (overlay-put o 'insert-in-front-hooks after-edit-functions)
 229     (org-num--refresh-display o numbering)
 230     o))
 231
 232 (defun org-num--refresh-display (overlay numbering)
 233   "Refresh OVERLAY's display.
 234 NUMBERING specifies the new numbering, as a list of integers, or
 235 nil if nothing should be displayed.  Assume OVERLAY is valid."
 236   (let ((display (and numbering
 237                       (funcall org-num-format-function (reverse numbering)))))
 238     (when (and display (not (get-text-property 0 'face display)))
 239       (org-add-props display `(face ,(overlay-get overlay 'numbering-face))))
 240     (overlay-put overlay 'after-string display)))
 241
 242 (defun org-num--skip-value ()
 243   "Return skip value for headline at point.
 244 Value is t when headline should not be numbered, and nil
 245 otherwise."
 246   (org-match-line org-complex-heading-regexp)
 247   (let ((title (match-string 4))
 248         (tags (and org-num-skip-tags
 249                    (match-end 5)
 250                    (org-split-string (match-string 5) ":"))))
 251     (or (and org-num-skip-footnotes
 252              org-footnote-section
 253              (equal title org-footnote-section))
 254         (and org-num-skip-commented
 255              (let ((case-fold-search nil))
 256                (string-match org-num--comment-re title))
 257              t)
 258         (and org-num-skip-tags
 259              (cl-some (lambda (tag) (member tag org-num-skip-tags))
 260                       tags)
 261              t)
 262         (and org-num-skip-unnumbered
 263              (org-entry-get (point) "UNNUMBERED")
 264              t))))
 265
 266 (defun org-num--current-numbering (level skip)
 267   "Return numbering for current headline.
 268 LEVEL is headline's level, and SKIP its skip value.  Return nil
 269 if headline should be skipped."
 270   (cond
 271    ;; Skipped by inheritance.
 272    ((and org-num--skip-level (> level org-num--skip-level)) nil)
 273    ;; Skipped by a non-nil skip value; set `org-num--skip-level'
 274    ;; to skip the whole sub-tree later on.
 275    (skip (setq org-num--skip-level level) nil)
 276    (t
 277     (setq org-num--skip-level nil)
 278     ;; Compute next numbering, and update `org-num--numbering'.
 279     (let ((last-level (length org-num--numbering)))
 280       (setq org-num--numbering
 281             (cond
 282              ;; First headline : nil => (1), or (1 0)...
 283              ((null org-num--numbering) (cons 1 (make-list (1- level) 0)))
 284              ;; Sibling: (1 1) => (2 1).
 285              ((= level last-level)
 286               (cons (1+ (car org-num--numbering)) (cdr org-num--numbering)))
 287              ;; Parent: (1 1 1) => (2 1), or (2).
 288              ((< level last-level)
 289               (let ((suffix (nthcdr (- last-level level) org-num--numbering)))
 290                 (cons (1+ (car suffix)) (cdr suffix))))
 291              ;; Child: (1 1) => (1 1 1), or (1 0 1 1)...
 292              (t
 293               (append (cons 1 (make-list (- level last-level 1) 0))
 294                       org-num--numbering))))))))
 295
 296 (defun org-num--number-region (start end)
 297   "Add numbering overlays between START and END positions.
 298 When START or END are nil, use buffer boundaries.  Narrowing, if
 299 any, is ignored.  Return the list of created overlays, newest
 300 first."
 301   (org-with-point-at (or start 1)
 302     ;; Do not match headline starting at START.
 303     (when start (end-of-line))
 304     (let ((regexp (org-num--headline-regexp))
 305           (new nil))
 306       (while (re-search-forward regexp end t)
 307         (let* ((level (org-reduced-level
 308                        (- (match-end 0) (match-beginning 0) 1)))
 309                (skip (org-num--skip-value))
 310                (numbering (org-num--current-numbering level skip)))
 311           ;; Apply numbering to current headline.  Store overlay for
 312           ;; the return value.
 313           (push (org-num--make-overlay numbering level skip)
 314                 new)))
 315       new)))
 316
 317 (defun org-num--update ()
 318   "Update buffer's numbering.
 319 This function removes invalid overlays and refreshes numbering
 320 for the valid ones in the numbering overlays list.  It also adds
 321 missing overlays to that list."
 322   (setq org-num--skip-level nil)
 323   (setq org-num--numbering nil)
 324   (let ((new-overlays nil)
 325         (overlay nil))
 326     (while (setq overlay (pop org-num--overlays))
 327       (cond
 328        ;; Valid overlay.
 329        ;;
 330        ;; First handle possible missing overlays OVERLAY.  If missing
 331        ;; overlay marker is pointing before next overlay and after the
 332        ;; last known overlay, make sure to parse the buffer between
 333        ;; these two overlays.
 334        ((org-num--valid-overlay-p overlay)
 335         (let ((next (overlay-start overlay))
 336               (last (and new-overlays (overlay-start (car new-overlays)))))
 337           (cond
 338            ((null org-num--missing-overlay))
 339            ((> org-num--missing-overlay next))
 340            ((or (null last) (> org-num--missing-overlay last))
 341             (setq org-num--missing-overlay nil)
 342             (setq new-overlays (nconc (org-num--number-region last next)
 343                                       new-overlays)))
 344            ;; If it is already after the last known overlay, reset it:
 345            ;; some previous invalid overlay already triggered the
 346            ;; necessary parsing.
 347            (t
 348             (setq org-num--missing-overlay nil))))
 349         ;; Update OVERLAY's numbering.
 350         (let* ((level (overlay-get overlay 'level))
 351                (skip (overlay-get overlay 'skip))
 352                (numbering (org-num--current-numbering level skip)))
 353           (org-num--refresh-display overlay numbering)
 354           (push overlay new-overlays)))
 355        ;; Invalid overlay.  It indicates that the buffer needs to be
 356        ;; parsed again between the two surrounding valid overlays or
 357        ;; buffer boundaries.
 358        (t
 359         ;; Delete all consecutive invalid overlays: we re-create all
 360         ;; overlays between last valid overlay and the next one.
 361         (delete-overlay overlay)
 362         (while (and org-num--overlays
 363                     (not (org-num--valid-overlay-p (car org-num--overlays))))
 364           (delete-overlay (pop org-num--overlays)))
 365         ;; Create and register new overlays.
 366         (let ((last (and new-overlays (overlay-start (car new-overlays))))
 367               (next (and org-num--overlays
 368                          (overlay-start (car org-num--overlays)))))
 369           (setq new-overlays (nconc (org-num--number-region last next)
 370                                     new-overlays))))))
 371     ;; If invalid position hasn't been handled yet, it must be located
 372     ;; between last valid overlay and end of the buffer.  Parse that
 373     ;; area before returning.
 374     (when org-num--missing-overlay
 375       (let ((last (and new-overlays (overlay-start (car new-overlays)))))
 376         (setq new-overlays (nconc (org-num--number-region last nil)
 377                                   new-overlays))))
 378     ;; Numbering is now up-to-date.  Reset invalid flag.  Also return
 379     ;; `org-num--overlays' in a sorted fashion.
 380     (setq org-num--invalid-flag nil)
 381     (setq org-num--overlays (nreverse new-overlays))))
 382
 383 (defun org-num--verify (beg end _)
 384   "Check numbering integrity; update it if necessary.
 385 This function is meant to be used in `after-change-functions'.
 386 See this variable for the meaning of BEG and END."
 387   (setq org-num--missing-overlay nil)
 388   (save-match-data
 389     (org-with-point-at beg
 390       (let ((regexp (org-num--headline-regexp)))
 391         ;; At this point, directly altered overlays between BEG and
 392         ;; END are marked as invalid and will trigger a full update.
 393         ;; However, there are still two cases to handle.
 394         ;;
 395         ;; First, some valid overlays may need to be invalidated, due
 396         ;; to an indirect change.  That happens when the skip value --
 397         ;; see `org-num--skip-value' -- of the heading BEG belongs to
 398         ;; is altered, or when deleting the newline character right
 399         ;; before the next headline.
 400         (save-excursion
 401           ;; Bail out if we're before first headline or within
 402           ;; a headline too deep to be numbered.
 403           (when (and (org-with-limited-levels
 404                       (ignore-errors (org-back-to-heading t)))
 405                      (looking-at regexp))
 406             (pcase (get-char-property-and-overlay (point) 'org-num)
 407               (`(nil)
 408                ;; At a headline, without a numbering overlay: change
 409                ;; just created one.  Mark it for parsing.
 410                (setq org-num--missing-overlay (point)))
 411               (`(t . ,o)
 412                ;; Check if skip value changed.  Invalidate overlay
 413                ;; accordingly.
 414                (unless (eq (org-num--skip-value) (overlay-get o 'skip))
 415                  (org-num--invalidate-overlay o)))
 416               (_ nil))))
 417         ;; Deleting the newline character before a numbering overlay
 418         ;; doesn't invalidate it, even though it could land in the
 419         ;; middle of a line.  Be sure to catch this case.
 420         (when (and (= beg end) (not (bolp)))
 421           (pcase (get-char-property-and-overlay (point) 'org-num)
 422             (`(t . ,o) (org-num--invalidate-overlay o))
 423             (_ nil)))
 424         ;; Second, if nothing is marked as invalid, and therefore if
 425         ;; no full update is due so far, changes may still have
 426         ;; created new headlines, at BEG -- which is actually handled
 427         ;; by the previous phase --, or, in case of a multi-line
 428         ;; insertion, at END, or in-between.
 429         (unless (or org-num--invalid-flag
 430                     org-num--missing-overlay
 431                     (<= end (line-end-position))) ;single line change
 432           (forward-line)
 433           (when (or (re-search-forward regexp end 'move)
 434                     ;; Check if change created a headline after END.
 435                     (progn (skip-chars-backward "*") (looking-at regexp)))
 436             (setq org-num--missing-overlay (line-beginning-position))))))
 437     ;; Update numbering only if a headline was altered or created.
 438     (when (or org-num--missing-overlay org-num--invalid-flag)
 439       (org-num--update))))
 440
 441 \f
 442 ;;; Public Functions
 443
 444 ;;;###autoload
 445 (defun org-num-default-format (numbering)
 446   "Default numbering display function.
 447 NUMBERING is a list of numbers."
 448   (concat (mapconcat #'number-to-string numbering ".") " "))
 449
 450 ;;;###autoload
 451 (define-minor-mode org-num-mode
 452   "Dynamic numbering of headlines in an Org buffer."
 453   :lighter " o#"
 454   (cond
 455    (org-num-mode
 456     (unless (derived-mode-p 'org-mode)
 457       (user-error "Cannot activate headline numbering outside Org mode"))
 458     (setq org-num--numbering nil)
 459     (setq org-num--overlays (nreverse (org-num--number-region nil nil)))
 460     (add-hook 'after-change-functions #'org-num--verify nil t)
 461     (add-hook 'change-major-mode-hook #'org-num--clear nil t))
 462    (t
 463     (org-num--clear)
 464     (remove-hook 'after-change-functions #'org-num--verify t)
 465     (remove-hook 'change-major-mode-hook #'org-num--clear t))))
 466
 467
 468 (provide 'org-num)
 469 ;;; org-num.el ends here