footnote.el 32.6 KB
Newer Older
1
;;; footnote.el --- footnote support for message mode  -*- lexical-binding:t -*-
Dave Love's avatar
Dave Love committed
2

Paul Eggert's avatar
Paul Eggert committed
3
;; Copyright (C) 1997, 2000-2019 Free Software Foundation, Inc.
Dave Love's avatar
Dave Love committed
4

5
;; Author: Steven L Baur <steve@xemacs.org> (1997-2011)
6
;;         Boruch Baum <boruch_baum@gmx.com> (2017-)
Dave Love's avatar
Dave Love committed
7 8 9
;; Keywords: mail, news
;; Version: 0.19

10
;; This file is part of GNU Emacs.
Dave Love's avatar
Dave Love committed
11

12 13 14 15
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
Dave Love's avatar
Dave Love committed
16

17 18 19 20
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
Dave Love's avatar
Dave Love committed
21 22

;; You should have received a copy of the GNU General Public License
23
;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
Dave Love's avatar
Dave Love committed
24 25 26 27 28 29 30 31 32

;;; Commentary:

;; This file provides footnote[1] support for message-mode in emacsen.
;; footnote-mode is implemented as a minor mode.

;; [1] Footnotes look something like this.  Along with some decorative
;; stuff.

33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62
;;;; TODO:
;; + Reasonable Undo support.
;;   - could use an `apply' entry in the buffer-undo-list to be warned when
;;     a footnote we inserted is removed via undo.
;;   - should try to handle the more general problem of deleting/removing
;;     footnotes via standard editing commands rather than via footnote
;;     commands.
;; + more language styles.
;; + The key sequence 'C-c ! a C-y C-c ! b' should auto-fill the
;;   footnote in adaptive fill mode. This does not seem to be a bug in
;;   `adaptive-fill' because it behaves that way on all point movements
;; + Handle footmode mode elegantly in all modes, even if that means refuses to
;;   accept the burden. For example, in a programming language mode, footnotes
;;   should be commented.
;; + Manually autofilling the a first footnote should not cause it to
;;   wrap into the footnote section tag
;;   + Current solution adds a second newline after the section tag, so it is
;;     clearly a separate paragraph. There may be stylistic objections to this.
;; + Footnotes with multiple paragraphs should not have their first
;;   line out-dented.
;; + Upon leaving footnote area, perform an auto-fill on an entire
;;   footnote (including multiple paragraphs), or on entire footnote area.
;;   + fill-paragraph takes arg REGION, but seemingly only when called
;;     interactively.
;; + At some point, it became necessary to change `footnote-section-tag-regexp'
;;   to remove its trailing space. (Adaptive fill side-effect?)
;; + useful for lazy testing
;;   (setq footnote-narrow-to-footnotes-when-editing t)
;;   (setq footnote-section-tag "Footnotes: ")
;;   (setq footnote-section-tag-regexp "Footnotes\\(\\[.\\]\\)?:")
Dave Love's avatar
Dave Love committed
63 64 65

;;; Code:

66 67
(eval-when-compile (require 'cl-lib))
(defvar filladapt-token-table)
68

Dave Love's avatar
Dave Love committed
69 70
(defgroup footnote nil
  "Support for footnotes in mail and news messages."
71
  :version "21.1"
Dave Love's avatar
Dave Love committed
72 73 74
  :group 'message)

(defcustom footnote-mode-line-string " FN"
75
  "String to display in modes section of the mode-line."
76
  :type 'string)
Dave Love's avatar
Dave Love committed
77 78

(defcustom footnote-narrow-to-footnotes-when-editing nil
79
  "If non-nil, narrow to footnote text body while editing a footnote."
80
  :type 'boolean)
Dave Love's avatar
Dave Love committed
81 82

(defcustom footnote-prompt-before-deletion t
83
  "If non-nil, prompt before deleting a footnote.
Dave Love's avatar
Dave Love committed
84
There is currently no way to undo deletions."
85
  :type 'boolean)
Dave Love's avatar
Dave Love committed
86 87

(defcustom footnote-spaced-footnotes t
88 89 90
  "If non-nil, insert an empty line between footnotes.
Customizing this variable has no effect on buffers already
displaying footnotes."
91
  :type 'boolean)
Dave Love's avatar
Dave Love committed
92

93 94
(defcustom footnote-use-message-mode t ; Nowhere used.
  "If non-nil, assume Footnoting will be done in `message-mode'."
95
  :type 'boolean)
Dave Love's avatar
Dave Love committed
96 97

(defcustom footnote-body-tag-spacing 2
98 99 100
  "Number of spaces separating a footnote body tag and its text.
Customizing this variable has no effect on buffers already
displaying footnotes."
101
  :type 'integer)
Dave Love's avatar
Dave Love committed
102

103
(defcustom footnote-prefix [(control ?c) ?!]
104
  "Prefix key to use for Footnote commands in Footnote minor mode.
105 106
The value of this variable is checked as part of loading Footnote mode.
After that, changing the prefix key requires manipulating keymaps."
107
  :type 'key-sequence)
Dave Love's avatar
Dave Love committed
108 109 110

;;; Interface variables that probably shouldn't be changed

111
(defcustom footnote-section-tag "Footnotes:"
112 113 114 115 116
  "Tag inserted at beginning of footnote section.
If you set this to the empty string, no tag is inserted and the
value of `footnote-section-tag-regexp' is ignored.  Customizing
this variable has no effect on buffers already displaying
footnotes."
117
  :version "27.1"
118
  :type 'string)
Dave Love's avatar
Dave Love committed
119

120 121 122 123
(defcustom footnote-section-tag-regexp
  ;; Even if `footnote-section-tag' has a trailing space, let's not require it
  ;; here, since it might be trimmed by various commands.
  "Footnotes\\(\\[.\\]\\)?:"
124 125 126 127
  "Regexp which indicates the start of a footnote section.
This variable is disregarded when `footnote-section-tag' is the
empty string.  Customizing this variable has no effect on buffers
already displaying footnotes."
128
  :version "27.1"
129
  :type 'regexp)
Dave Love's avatar
Dave Love committed
130 131

;; The following three should be consumed by footnote styles.
132
(defcustom footnote-start-tag "["
133 134 135
  "String used to denote start of numbered footnote.
Should not be set to the empty string.  Customizing this variable
has no effect on buffers already displaying footnotes."
136
  :type 'string)
Dave Love's avatar
Dave Love committed
137

138
(defcustom footnote-end-tag "]"
139 140 141
  "String used to denote end of numbered footnote.
Should not be set to the empty string.  Customizing this variable
has no effect on buffers already displaying footnotes."
142
  :type 'string)
Dave Love's avatar
Dave Love committed
143

144 145 146 147
(defcustom footnote-signature-separator
  (if (boundp 'message-signature-separator)
      message-signature-separator
    "^-- $")
148
  "Regexp used by Footnote mode to recognize signatures."
149
  :type 'regexp)
Dave Love's avatar
Dave Love committed
150

151
(defcustom footnote-align-to-fn-text t
152 153 154 155
  "How to left-align footnote text.
If nil, footnote text is to be aligned flush left with left side
of the footnote number. If non-nil, footnote text is to be aligned
left with the first character of footnote text."
156 157
  :type  'boolean)

Dave Love's avatar
Dave Love committed
158 159
;;; Private variables

160 161
(defvar-local footnote-style-number nil
  "Footnote style represented as an index into `footnote-style-alist'.")
Dave Love's avatar
Dave Love committed
162

163 164 165 166
(defvar-local footnote--markers-alist nil
  "List of (FN TEXT . POINTERS).
Where FN is the footnote number, TEXT is a marker pointing to
the footnote's text, and POINTERS is a list of markers pointing
167
to the places from which the footnote is referenced.
168
Both TEXT and POINTERS points right *before* the [...]")
Dave Love's avatar
Dave Love committed
169 170

(defvar footnote-mouse-highlight 'highlight
171 172
  ;; FIXME: This `highlight' property is not currently used.
  ;; We should use `mouse-face' and make mouse clicks work on them.
Dave Love's avatar
Dave Love committed
173 174
  "Text property name to enable mouse over highlight.")

175 176
(defvar footnote-mode)

Dave Love's avatar
Dave Love committed
177 178
;;; Default styles
;;; NUMERIC
Glenn Morris's avatar
Glenn Morris committed
179
(defconst footnote-numeric-regexp "[0-9]+"
Dave Love's avatar
Dave Love committed
180 181
  "Regexp for digits.")

182
(defun footnote--numeric (n)
Dave Love's avatar
Dave Love committed
183 184 185 186 187 188 189 190
  "Numeric footnote style.
Use Arabic numerals for footnoting."
  (int-to-string n))

;;; ENGLISH UPPER
(defconst footnote-english-upper "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  "Upper case English alphabet.")

Glenn Morris's avatar
Glenn Morris committed
191
(defconst footnote-english-upper-regexp "[A-Z]+"
Dave Love's avatar
Dave Love committed
192 193
  "Regexp for upper case English alphabet.")

194
(defun footnote--english-upper (n)
Dave Love's avatar
Dave Love committed
195 196 197 198 199 200 201 202 203 204
  "Upper case English footnoting.
Wrapping around the alphabet implies successive repetitions of letters."
  (let* ((ltr (mod (1- n) (length footnote-english-upper)))
	 (rep (/ (1- n) (length footnote-english-upper)))
	 (chr (char-to-string (aref footnote-english-upper ltr)))
	 rc)
    (while (>= rep 0)
      (setq rc (concat rc chr))
      (setq rep (1- rep)))
    rc))
205

Dave Love's avatar
Dave Love committed
206 207 208 209
;;; ENGLISH LOWER
(defconst footnote-english-lower "abcdefghijklmnopqrstuvwxyz"
  "Lower case English alphabet.")

Glenn Morris's avatar
Glenn Morris committed
210
(defconst footnote-english-lower-regexp "[a-z]+"
Dave Love's avatar
Dave Love committed
211 212
  "Regexp of lower case English alphabet.")

213
(defun footnote--english-lower (n)
Dave Love's avatar
Dave Love committed
214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230
  "Lower case English footnoting.
Wrapping around the alphabet implies successive repetitions of letters."
  (let* ((ltr (mod (1- n) (length footnote-english-lower)))
	 (rep (/ (1- n) (length footnote-english-lower)))
	 (chr (char-to-string (aref footnote-english-lower ltr)))
	 rc)
    (while (>= rep 0)
      (setq rc (concat rc chr))
      (setq rep (1- rep)))
    rc))

;;; ROMAN LOWER
(defconst footnote-roman-lower-list
  '((1 . "i") (5 . "v") (10 . "x")
    (50 . "l") (100 . "c") (500 . "d") (1000 . "m"))
  "List of roman numerals with their values.")

231 232
(defconst footnote-roman-lower-regexp
  (concat "[" (mapconcat #'cdr footnote-roman-lower-list "") "]+")
Dave Love's avatar
Dave Love committed
233 234
  "Regexp of roman numerals.")

235
(defun footnote--roman-lower (n)
Dave Love's avatar
Dave Love committed
236
  "Generic Roman number footnoting."
237
  (footnote--roman-common n footnote-roman-lower-list))
Dave Love's avatar
Dave Love committed
238 239 240

;;; ROMAN UPPER
(defconst footnote-roman-upper-list
241 242
  (mapcar (lambda (x) (cons (car x) (upcase (cdr x))))
          footnote-roman-lower-list)
Dave Love's avatar
Dave Love committed
243 244
  "List of roman numerals with their values.")

245
(defconst footnote-roman-upper-regexp (upcase footnote-roman-lower-regexp)
Dave Love's avatar
Dave Love committed
246 247
  "Regexp of roman numerals.  Not complete")

248
(defun footnote--roman-upper (n)
Dave Love's avatar
Dave Love committed
249
  "Generic Roman number footnoting."
250
  (footnote--roman-common n footnote-roman-upper-list))
Dave Love's avatar
Dave Love committed
251

252
(defun footnote--roman-common (n footnote-roman-list)
Dave Love's avatar
Dave Love committed
253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286
  "Lower case Roman footnoting."
  (let* ((our-list footnote-roman-list)
	 (rom-lngth (length our-list))
	 (rom-high 0)
	 (rom-low 0)
	 (rom-div -1)
	 (count-high 0)
	 (count-low 0))
    ;; find surrounding numbers
    (while (and (<= count-high (1- rom-lngth))
		(>= n (car (nth count-high our-list))))
      ;; (message "Checking %d" (car (nth count-high our-list)))
      (setq count-high (1+ count-high)))
    (setq rom-high count-high)
    (setq rom-low (1- count-high))
    ;; find the appropriate divisor (if it exists)
    (while (and (= rom-div -1)
		(< count-low rom-high))
      (when (or (> n (- (car (nth rom-high our-list))
			(/ (car (nth count-low our-list))
			   2)))
		(= n (- (car (nth rom-high our-list))
			(car (nth count-low our-list)))))
	(setq rom-div count-low))
      ;; (message "Checking %d and %d in div loop" rom-high count-low)
      (setq count-low (1+ count-low)))
    ;;(message "We now have high: %d, low: %d, div: %d, n: %d"
    ;;	       rom-high rom-low (if rom-div rom-div -1) n)
    (let ((rom-low-pair (nth rom-low our-list))
	  (rom-high-pair (nth rom-high our-list))
	  (rom-div-pair (if (not (= rom-div -1)) (nth rom-div our-list) nil)))
      ;; (message "pairs are: rom-low: %S, rom-high: %S, rom-div: %S"
      ;;	  rom-low-pair rom-high-pair rom-div-pair)
      (cond
287
       ((< n 0) (error "footnote--roman-common called with n < 0"))
Dave Love's avatar
Dave Love committed
288 289 290 291 292
       ((= n 0) "")
       ((= n (car rom-low-pair)) (cdr rom-low-pair))
       ((= n (car rom-high-pair)) (cdr rom-high-pair))
       ((= (car rom-low-pair) (car rom-high-pair))
	(concat (cdr rom-low-pair)
293
		(footnote--roman-common
Dave Love's avatar
Dave Love committed
294 295 296
		 (- n (car rom-low-pair))
		 footnote-roman-list)))
       ((>= rom-div 0) (concat (cdr rom-div-pair) (cdr rom-high-pair)
297
			       (footnote--roman-common
Dave Love's avatar
Dave Love committed
298 299 300 301
				(- n (- (car rom-high-pair)
					(car rom-div-pair)))
				footnote-roman-list)))
       (t (concat (cdr rom-low-pair)
302
		  (footnote--roman-common
Dave Love's avatar
Dave Love committed
303 304 305
		   (- n (car rom-low-pair))
		   footnote-roman-list)))))))

306 307
;; Latin-1

308
(defconst footnote-latin-string "¹²³ºª§¶"
309 310
  "String of Latin-1 footnoting characters.")

Glenn Morris's avatar
Glenn Morris committed
311
;; Note not [...]+, because this style cycles.
312
(defconst footnote-latin-regexp (concat "[" footnote-latin-string "]")
313 314
  "Regexp for Latin-1 footnoting characters.")

315
(defun footnote--latin (n)
316 317
  "Latin-1 footnote style.
Use a range of Latin-1 non-ASCII characters for footnoting."
318 319
  (string (aref footnote-latin-string
		(mod (1- n) (length footnote-latin-string)))))
320

Leo Liu's avatar
Leo Liu committed
321 322 323
;; Unicode

(defconst footnote-unicode-string "⁰¹²³⁴⁵⁶⁷⁸⁹"
Juanma Barranquero's avatar
Juanma Barranquero committed
324
  "String of Unicode footnoting characters.")
Leo Liu's avatar
Leo Liu committed
325 326

(defconst footnote-unicode-regexp (concat "[" footnote-unicode-string "]+")
Juanma Barranquero's avatar
Juanma Barranquero committed
327
  "Regexp for Unicode footnoting characters.")
Leo Liu's avatar
Leo Liu committed
328

329
(defun footnote--unicode (n)
Leo Liu's avatar
Leo Liu committed
330
  "Unicode footnote style.
Juanma Barranquero's avatar
Juanma Barranquero committed
331
Use Unicode characters for footnoting."
Leo Liu's avatar
Leo Liu committed
332 333 334 335 336 337 338 339
  (let (modulus result done)
    (while (not done)
      (setq modulus (mod n 10)
            n (truncate n 10))
      (and (zerop n) (setq done t))
      (push (aref footnote-unicode-string modulus) result))
    (apply #'string result)))

340 341 342 343 344 345
;; Hebrew

(defconst footnote-hebrew-numeric
  '(
    ("א" "ב" "ג" "ד" "ה" "ו" "ז" "ח" "ט")
    ("י" "כ" "ל" "מ" "נ" "ס" "ע" "פ" "צ")
346 347 348
    ("ק" "ר" "ש" "ת" "תק" "תר" "תש" "תת" "תתק")))

(defconst footnote-hebrew-numeric-regex
349 350
  (let ((numchars (string-to-list
		   (apply #'concat (apply #'append footnote-hebrew-numeric)))))
351
    (rx-to-string `(1+ (in ?' ,@numchars)))))
352
;; (defconst footnote-hebrew-numeric-regex "\\([אבגדהוזחט]'\\)?\\(ת\\)?\\(ת\\)?\\([קרשת]\\)?\\([טיכלמנסעפצ]\\)?\\([אבגדהוזחט]\\)?")
353

354
(defun footnote--hebrew-numeric (n)
355 356 357 358 359 360
  "Supports 9999 footnotes, then rolls over."
  (let* ((n (+ (mod n 10000) (/ n 10000)))
         (thousands (/ n 1000))
         (hundreds (/ (mod n 1000) 100))
         (tens (/ (mod n 100) 10))
         (units (mod n 10))
361 362 363 364
         (special (cond
                   ((not (= tens 1)) nil)
                   ((= units 5) "טו")
                   ((= units 6) "טז"))))
365 366 367 368 369
    (concat
     (when (/= 0 thousands)
       (concat (nth (1- thousands) (nth 0 footnote-hebrew-numeric)) "'"))
     (when (/= 0 hundreds)
       (nth (1- hundreds) (nth 2 footnote-hebrew-numeric)))
370 371 372 373
     (or special
         (concat
          (when (/= 0 tens) (nth (1- tens) (nth 1 footnote-hebrew-numeric)))
          (when (/= 0 units) (nth (1- units) (nth 0 footnote-hebrew-numeric))))))))
374 375 376 377 378

(defconst footnote-hebrew-symbolic
  '(
    "א" "ב" "ג" "ד" "ה" "ו" "ז" "ח" "ט" "י" "כ" "ל" "מ" "נ" "ס" "ע" "פ" "צ" "ק" "ר" "ש" "ת"))

379 380 381
(defconst footnote-hebrew-symbolic-regex
  (concat "[" (apply #'concat footnote-hebrew-symbolic) "]"))

382
(defun footnote--hebrew-symbolic (n)
383 384 385 386
  "Only 22 elements, per the style of eg. 'פירוש שפתי חכמים על רש״י'.
Proceeds from `י' to `כ', from `צ' to `ק'. After `ת', rolls over to `א'."
  (nth (mod (1- n) 22) footnote-hebrew-symbolic))

Dave Love's avatar
Dave Love committed
387 388
;;; list of all footnote styles
(defvar footnote-style-alist
389 390 391 392 393 394 395 396 397
  `((numeric footnote--numeric ,footnote-numeric-regexp)
    (english-lower footnote--english-lower ,footnote-english-lower-regexp)
    (english-upper footnote--english-upper ,footnote-english-upper-regexp)
    (roman-lower footnote--roman-lower ,footnote-roman-lower-regexp)
    (roman-upper footnote--roman-upper ,footnote-roman-upper-regexp)
    (latin footnote--latin ,footnote-latin-regexp)
    (unicode footnote--unicode ,footnote-unicode-regexp)
    (hebrew-numeric footnote--hebrew-numeric ,footnote-hebrew-numeric-regex)
    (hebrew-symbolic footnote--hebrew-symbolic ,footnote-hebrew-symbolic-regex))
Dave Love's avatar
Dave Love committed
398
  "Styles of footnote tags available.
399 400
By default, Arabic numbers, English letters, Roman Numerals,
Latin and Unicode superscript characters, and Hebrew numerals
401 402 403 404 405
are available.
Each element of the list should be of the form (NAME FUNCTION REGEXP)
where NAME is a symbol, FUNCTION takes a footnote number and
returns the corresponding representation in that style as a string,
and REGEXP should be a regexp that matches any output of FUNCTION.")
Dave Love's avatar
Dave Love committed
406

407
(defcustom footnote-style 'numeric
408
  "Default style used for footnoting.
409 410 411 412 413
numeric == 1, 2, 3, ...
english-lower == a, b, c, ...
english-upper == A, B, C, ...
roman-lower == i, ii, iii, iv, v, ...
roman-upper == I, II, III, IV, V, ...
414
latin == ¹ ² ³ º ª § ¶
Leo Liu's avatar
Leo Liu committed
415
unicode == ¹, ², ³, ...
416 417
hebrew-numeric == א, ב, ..., יא, ..., תקא...
hebrew-symbolic == א, ב, ..., י, כ, ..., צ, ק, ..., ת, א
418 419
See also variables `footnote-start-tag' and `footnote-end-tag'.

Leo Liu's avatar
Leo Liu committed
420 421 422
Note: some characters in the unicode style may not show up
properly if the default font does not contain those characters.

423
Customizing this variable has no effect on buffers already
424
displaying footnotes.  To change the style of footnotes in such a
425
buffer use the command `footnote-set-style'."
426
  :type (cons 'choice (mapcar (lambda (x) (list 'const (car x)))
427
			      footnote-style-alist)))
428

Dave Love's avatar
Dave Love committed
429 430
;;; Style utilities & functions

431
(defun footnote--index-to-string (index)
Dave Love's avatar
Dave Love committed
432 433
  "Convert a binary index into a string to display as a footnote.
Conversion is done based upon the current selected style."
434 435
  (let ((alist (or (assq footnote-style footnote-style-alist)
		   (nth 0 footnote-style-alist))))
Dave Love's avatar
Dave Love committed
436 437
    (funcall (nth 1 alist) index)))

438
(defun footnote--current-regexp (&optional index-regexp)
Dave Love's avatar
Dave Love committed
439
  "Return the regexp of the index of the current style."
440 441 442
  (let ((regexp (or index-regexp
                    (nth 2 (or (assq footnote-style footnote-style-alist)
			       (nth 0 footnote-style-alist))))))
Paul Eggert's avatar
Paul Eggert committed
443
    (concat
444
     (regexp-quote footnote-start-tag) "\\("
Paul Eggert's avatar
Paul Eggert committed
445
     ;; Hack to avoid repetition of repetition.
446 447
     ;; FIXME: I'm not sure the added * makes sense at all; there is
     ;; always a single number within the footnote-{start,end}-tag pairs.
Paul Eggert's avatar
Paul Eggert committed
448 449 450
     (if (string-match "[^\\]\\\\\\{2\\}*[*+?]\\'" regexp)
	 (substring regexp 0 -1)
       regexp)
451
     "*\\)" (regexp-quote footnote-end-tag))))
Dave Love's avatar
Dave Love committed
452

453
(defun footnote--refresh-footnotes (&optional index-regexp)
Dave Love's avatar
Dave Love committed
454
  "Redraw all footnotes.
455 456
You must call this or arrange to have this called after changing
footnote styles."
457
  (let ((fn-regexp (footnote--current-regexp index-regexp)))
458 459
    (save-excursion
      (pcase-dolist (`(,fn ,text . ,pointers) footnote--markers-alist)
460
        ;; Take care of the pointers first.
461 462
	(dolist (locn pointers)
	  (goto-char locn)
463 464
	  ;; Try to handle the case where `footnote-start-tag' and
	  ;; `footnote-end-tag' are the same string.
465
	  (when (looking-at fn-regexp)
466 467 468 469
	    (replace-match
	     (propertize
	      (concat
	       footnote-start-tag
470
	       (footnote--index-to-string fn)
471
	       footnote-end-tag)
472 473 474 475 476 477
	      'footnote-number fn footnote-mouse-highlight t)
	     t t)))

        ;; Now take care of the text section
	(goto-char text)
	(when (looking-at fn-regexp)
478 479 480 481
	  (replace-match
	   (propertize
	    (concat
	     footnote-start-tag
482
	     (footnote--index-to-string fn)
483
	     footnote-end-tag)
484 485
	    'footnote-number fn)
	   t t))))))
Dave Love's avatar
Dave Love committed
486

487
(defun footnote-cycle-style ()
Dave Love's avatar
Dave Love committed
488 489
  "Select next defined footnote style."
  (interactive)
490 491 492
  (let ((old-desc (assq footnote-style footnote-style-alist)))
    (setq footnote-style (caar (or (cdr (memq old-desc footnote-style-alist))
                                   footnote-style-alist)))
493 494
    (footnote--refresh-footnotes (nth 2 old-desc))
    (message "Style set to %s" footnote-style)))
495 496

(defun footnote-set-style (style)
Dave Love's avatar
Dave Love committed
497 498 499 500
  "Select a specific style."
  (interactive
   (list (intern (completing-read
		  "Footnote Style: "
501 502
		  footnote-style-alist nil 'require-match))))
  (let ((old-desc (assq footnote-style footnote-style-alist)))
503
    (setq footnote-style style)
504
    (footnote--refresh-footnotes (nth 2 old-desc))))
Dave Love's avatar
Dave Love committed
505 506

;; Internal functions
507
(defun footnote--insert-numbered-footnote (arg &optional mousable)
508 509
  "Insert numbered footnote at point.
Return a marker pointing to the beginning of the [...]."
510
  (let ((string (concat footnote-start-tag
511
			(footnote--index-to-string arg)
512 513
			footnote-end-tag))
        (pos (point)))
514
    (insert
515 516 517
     (if mousable
	 (propertize
	  string 'footnote-number arg footnote-mouse-highlight t)
518 519
       (propertize string 'footnote-number arg)))
    (copy-marker pos t)))
Dave Love's avatar
Dave Love committed
520

521
(defun footnote--renumber (to alist-elem)
Dave Love's avatar
Dave Love committed
522
  "Renumber a single footnote."
523
  (unless (equal to (car alist-elem))   ;Nothing to do.
524
    (let* ((fn-regexp (footnote--current-regexp)))
525 526 527
      (setcar alist-elem to)
      (dolist (posn (cddr alist-elem))
        (goto-char posn)
528
        (when (looking-at fn-regexp)
529 530 531 532 533 534 535 536 537 538
	  (replace-match
	   (propertize
	    (concat footnote-start-tag
		    (footnote--index-to-string to)
		    footnote-end-tag)
	    'footnote-number to footnote-mouse-highlight t))))
      (goto-char (cadr alist-elem))
      (when (looking-at fn-regexp)
        (replace-match
         (propertize
539
	  (concat footnote-start-tag
540
		  (footnote--index-to-string to)
541
		  footnote-end-tag)
542
	  'footnote-number to))))))
Dave Love's avatar
Dave Love committed
543

544
(defun footnote--narrow-to-footnotes ()
Dave Love's avatar
Dave Love committed
545
  "Restrict text in buffer to show only text of footnotes."
546
  (interactive) ; testing
547 548
  (narrow-to-region (footnote--get-area-point-min)
                    (footnote--get-area-point-max)))
Dave Love's avatar
Dave Love committed
549

550
(defun footnote--goto-char-point-max ()
Dave Love's avatar
Dave Love committed
551 552 553 554 555
  "Move to end of buffer or prior to start of .signature."
  (goto-char (point-max))
  (or (re-search-backward footnote-signature-separator nil t)
      (point)))

556 557 558 559 560 561 562
(defun footnote--insert-markers (arg text ptr)
  "Insert the markers of new footnote ARG."
  (cl-assert (and (numberp arg) (markerp text) (markerp ptr)))
  (cl-assert (not (assq arg footnote--markers-alist)))
  (push `(,arg ,text ,ptr) footnote--markers-alist)
  (setq footnote--markers-alist
	(footnote--sort footnote--markers-alist)))
563 564 565 566 567 568 569 570 571

(defun footnote--goto-first ()
  "Go to beginning of footnote area and return non-nil if successful.
Presumes we're within the footnote area already."
  (cond
   ((not (string-equal footnote-section-tag ""))
    (re-search-backward
     (concat "^" footnote-section-tag-regexp) nil t))
   (footnote--markers-alist
572
    (goto-char (cadr (car footnote--markers-alist))))))
Dave Love's avatar
Dave Love committed
573

574
(defun footnote--insert-footnote (arg)
575
  "Insert a footnote numbered ARG, at (point)."
Dave Love's avatar
Dave Love committed
576
  (push-mark)
577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602
  (let ((ptr (footnote--insert-numbered-footnote arg t)))
    (footnote--goto-char-point-max)
    (if (footnote--goto-first)
        (save-restriction
	  (when footnote-narrow-to-footnotes-when-editing
	    (footnote--narrow-to-footnotes))
	  (footnote-goto-footnote (1- arg)) ; evil, FIXME (less evil now)
	  ;; (message "Inserting footnote %d" arg)
	  (or (eq arg 1)
	      (when (re-search-forward
		     (if footnote-spaced-footnotes
			 "\n\n"
		       (concat "\n" (footnote--current-regexp)))
		     nil t)
		(beginning-of-line)
                t)
	      (footnote--goto-char-point-max)
	      (footnote--goto-first)))
      (unless (looking-at "^$")
        (insert "\n"))
      (when (eobp)
        (insert "\n"))
      (unless (string-equal footnote-section-tag "")
        (insert footnote-section-tag "\n")))
    (let ((text (footnote--insert-numbered-footnote arg nil)))
      (footnote--insert-markers arg text ptr))))
Dave Love's avatar
Dave Love committed
603

604
(defun footnote--sort (list)
605
  (sort list #'car-less-than-car))
Dave Love's avatar
Dave Love committed
606

607
(defun footnote--text-under-cursor ()
608
  "Return the number of the current footnote if in footnote text.
Pavel Janík's avatar
Pavel Janík committed
609
Return nil if the cursor is not positioned over the text of
Dave Love's avatar
Dave Love committed
610
a footnote."
611 612 613 614 615
  (when (<= (point) (footnote--get-area-point-max))
    (let ((result nil))
      (pcase-dolist (`(,fn ,text . ,_) footnote--markers-alist)
        (if (<= text (point))
            (setq result fn)))
616
      result)))
Dave Love's avatar
Dave Love committed
617

618
(defun footnote--under-cursor ()
Dave Love's avatar
Dave Love committed
619
  "Return the number of the footnote underneath the cursor.
Pavel Janík's avatar
Pavel Janík committed
620
Return nil if the cursor is not over a footnote."
Dave Love's avatar
Dave Love committed
621
  (or (get-text-property (point) 'footnote-number)
622
      (footnote--text-under-cursor)))
Dave Love's avatar
Dave Love committed
623

624
(defun footnote--calc-fn-alignment-column ()
625 626 627 628 629 630
  "Calculate the left alignment for footnote text."
  ;; FIXME: Maybe it would be better to go to the footnote's beginning and
  ;; see at which column it starts.
  (+ footnote-body-tag-spacing
     (string-width
      (concat footnote-start-tag  footnote-end-tag
631
              (footnote--index-to-string
632
               (caar (last footnote--markers-alist)))))))
633

634
(defun footnote--fill-prefix-string ()
635 636 637
  "Return the fill prefix to be used by footnote mode."
  ;; TODO: Prefix to this value other prefix strings, such as those
  ;; designating a comment line, a message response, or a boxquote.
638
  (make-string (footnote--calc-fn-alignment-column) ?\s))
639

640
(defun footnote--point-in-body-p ()
641 642
  "Return non-nil if point is in the buffer text area,
i.e. before the beginning of the footnote area."
643
  (< (point) (footnote--get-area-point-min)))
644

645
(defun footnote--get-area-point-min (&optional before-tag)
646 647 648 649 650
  "Return start of the first footnote.
If there is no footnote area, returns `point-max'.
With optional arg BEFORE-TAG, return position of the `footnote-section-tag'
instead, if applicable."
  (cond
651
   ;; FIXME: Shouldn't we use `footnote--get-area-point-max' instead?
652 653 654
   ((not footnote--markers-alist) (point-max))
   ((not before-tag) (cadr (car footnote--markers-alist)))
   ((string-equal footnote-section-tag "") (cadr (car footnote--markers-alist)))
655 656
   (t
    (save-excursion
657
      (goto-char (cadr (car footnote--markers-alist)))
658
      (if (re-search-backward (concat "^" footnote-section-tag-regexp) nil t)
659
          (point)
660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676
        (message "Footnote section tag not found!")
        ;; This `else' should never happen, and indicates an error,
        ;; ie. footnotes already exist and a footnote-section-tag is defined,
        ;; but the section tag hasn't been found. We choose to assume that the
        ;; user deleted it intentionally and wants us to behave in this buffer
        ;; as if the section tag was set "", so we do that, now.
        ;;(setq footnote-section-tag "")
        ;;
        ;; HOWEVER: The rest of footnote mode does not currently honor or
        ;; account for this.
        ;;
        ;; To illustrate the difference in behavior, create a few footnotes,
        ;; delete the section tag, and create another footnote. Then undo,
        ;; comment the above line (that sets the tag to ""), re-evaluate this
        ;; function, and repeat.
        ;;
        ;; TODO: integrate sanity checks at reasonable operational points.
677
        (point))))))
678

679
(defun footnote--get-area-point-max ()
680 681 682 683
  "Return the end of footnote area.
This is either `point-max' or the start of a `.signature' string, as
defined by variable `footnote-signature-separator'. If there is no
footnote area, returns `point-max'."
684
  (save-excursion (footnote--goto-char-point-max)))
685

686
(defun footnote--adaptive-fill-function (orig-fun)
687 688 689 690
  (or
   (and
    footnote-mode
    footnote-align-to-fn-text
691 692 693 694
    (footnote--text-under-cursor)
    ;; (not (footnote--point-in-body-p))
    ;; (< (point) (footnote--signature-area-start-point))
    (footnote--fill-prefix-string))
695 696 697
   ;; If not within a footnote's text, fallback to the default.
   (funcall orig-fun)))

Dave Love's avatar
Dave Love committed
698 699
;;; User functions

700
(defun footnote--make-hole ()
701 702
  "Make room in the alist for a new footnote at point.
Return the footnote number to use."
Dave Love's avatar
Dave Love committed
703
  (save-excursion
704 705
    (let (rc)
      (dolist (alist-elem footnote--markers-alist)
706
	(when (<= (point) (cl-caddr alist-elem))
Dave Love's avatar
Dave Love committed
707
	  (unless rc
708
	    (setq rc (car alist-elem)))
Dave Love's avatar
Dave Love committed
709
	  (save-excursion
710
	    (message "Renumbering from %s to %s"
711
		     (footnote--index-to-string (car alist-elem))
712
		     (footnote--index-to-string
713 714
		      (1+ (car alist-elem))))
	    (footnote--renumber (1+ (car alist-elem))
715
			        alist-elem))))
716 717
      (or rc
          (1+ (or (caar (last footnote--markers-alist)) 0))))))
Dave Love's avatar
Dave Love committed
718

719
(defun footnote-add-footnote ()
Dave Love's avatar
Dave Love committed
720 721 722 723 724
  "Add a numbered footnote.
The number the footnote receives is dependent upon the relative location
of any other previously existing footnotes.
If the variable `footnote-narrow-to-footnotes-when-editing' is set,
the buffer is narrowed to the footnote body.  The restriction is removed
725
by using `footnote-back-to-message'."
726
  (interactive "*")
727
  (let ((num (footnote--make-hole)))
Dave Love's avatar
Dave Love committed
728
    (message "Adding footnote %d" num)
729
    (footnote--insert-footnote num)
730 731 732 733 734 735 736 737
    (insert (make-string footnote-body-tag-spacing ? ))
    (save-excursion
      (insert
       (if footnote-spaced-footnotes
	   "\n\n"
	 "\n"))
      (when footnote-narrow-to-footnotes-when-editing
	(footnote--narrow-to-footnotes)))))
Dave Love's avatar
Dave Love committed
738

739
(defun footnote-delete-footnote (&optional arg)
Dave Love's avatar
Dave Love committed
740
  "Delete a numbered footnote.
741
With no parameter, delete the footnote under (point).  With ARG specified,
Dave Love's avatar
Dave Love committed
742 743 744
delete the footnote with that number."
  (interactive "*P")
  (unless arg
745
    (setq arg (footnote--under-cursor)))
Dave Love's avatar
Dave Love committed
746 747 748
  (when (and arg
	     (or (not footnote-prompt-before-deletion)
		 (y-or-n-p (format "Really delete footnote %d?" arg))))
749 750
    (let ((alist-elem (or (assq arg footnote--markers-alist)
                          (error "Can't delete footnote %d" arg)))
751
          (fn-regexp (footnote--current-regexp)))
752
      (dolist (locn (cddr alist-elem))
Dave Love's avatar
Dave Love committed
753
	(save-excursion
754
	  (goto-char locn)
755
	  (when (looking-at fn-regexp)
756
	    (delete-region (match-beginning 0) (match-end 0)))))
Dave Love's avatar
Dave Love committed
757
      (save-excursion
758
	(goto-char (cadr alist-elem))
759 760 761 762
	(delete-region
	 (point)
	 (if footnote-spaced-footnotes
	     (search-forward "\n\n" nil t)
763
           (save-restriction ; <= 2017-12 Boruch: WHY?? I see no narrowing / widening here.
764 765
	     (end-of-line)
	     (next-single-char-property-change
766
	      (point) 'footnote-number nil (footnote--goto-char-point-max))))))
767 768
      (setq footnote--markers-alist
	    (delq alist-elem footnote--markers-alist))
769 770
      (if footnote--markers-alist
          (footnote-renumber-footnotes)
Dave Love's avatar
Dave Love committed
771
	(save-excursion
772
	  (if (not (string-equal footnote-section-tag ""))
773
	      (let* ((end (footnote--goto-char-point-max))
774 775 776 777 778 779 780 781 782
		     (start (1- (re-search-backward
				 (concat "^" footnote-section-tag-regexp)
				 nil t))))
		(forward-line -1)
		(when (looking-at "\n")
		  (kill-line))
		(delete-region start (if (< end (point-max))
					 end
				       (point-max))))
783
	    (footnote--goto-char-point-max)
784
	    (when (looking-back "\n\n" (- (point) 2))
785
	      (kill-line -1))))))))
Dave Love's avatar
Dave Love committed
786

787
(defun footnote-renumber-footnotes ()
Dave Love's avatar
Dave Love committed
788
  "Renumber footnotes, starting from 1."
789
  (interactive "*")
Dave Love's avatar
Dave Love committed
790
  (save-excursion
791 792 793
    (let ((i 1))
      (dolist (alist-elem footnote--markers-alist)
	(footnote--renumber i alist-elem)
Dave Love's avatar
Dave Love committed
794 795
	(setq i (1+ i))))))

796
(defun footnote-goto-footnote (&optional arg)
Dave Love's avatar
Dave Love committed
797
  "Jump to the text of a footnote.
798
With no parameter, jump to the text of the footnote under (point).  With ARG
Dave Love's avatar
Dave Love committed
799 800
specified, jump to the text of that footnote."
  (interactive "P")
801
  (unless arg
802
    (setq arg (footnote--under-cursor)))
803
  (let ((footnote (assq arg footnote--markers-alist)))
804 805
    (cond
     (footnote
806
      (goto-char (cadr footnote)))
807 808 809 810 811 812
     ((eq arg 0)
      (goto-char (point-max))
      (cond
       ((not (string-equal footnote-section-tag ""))
	(re-search-backward (concat "^" footnote-section-tag-regexp))
	(forward-line 1))
813 814
       (footnote--markers-alist
	(goto-char (cadr (car footnote--markers-alist))))))
815 816
     (t
      (error "I don't see a footnote here")))))
Dave Love's avatar
Dave Love committed
817

818
(defun footnote-back-to-message ()
Dave Love's avatar
Dave Love committed
819 820 821 822
  "Move cursor back to footnote referent.
If the cursor is not over the text of a footnote, point is not changed.
If the buffer was narrowed due to `footnote-narrow-to-footnotes-when-editing'
being set it is automatically widened."
823
  (interactive)
824
  (let ((note (footnote--text-under-cursor)))
Dave Love's avatar
Dave Love committed
825 826 827
    (when note
      (when footnote-narrow-to-footnotes-when-editing
	(widen))
828 829 830
      (goto-char (cl-caddr (assq note footnote--markers-alist)))
      (when (looking-at (footnote--current-regexp))
        (goto-char (match-end 0))))))
Dave Love's avatar
Dave Love committed
831

832 833
(defvar footnote-mode-map
  (let ((map (make-sparse-keymap)))
834 835 836 837 838 839 840
    (define-key map "a" #'footnote-add-footnote)
    (define-key map "b" #'footnote-back-to-message)
    (define-key map "c" #'footnote-cycle-style)
    (define-key map "d" #'footnote-delete-footnote)
    (define-key map "g" #'footnote-goto-footnote)
    (define-key map "r" #'footnote-renumber-footnotes)
    (define-key map "s" #'footnote-set-style)
841 842 843 844 845 846
    map))

(defvar footnote-minor-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map footnote-prefix footnote-mode-map)
    map)
Dave Love's avatar
Dave Love committed
847 848 849
  "Keymap used for binding footnote minor mode.")

;;;###autoload
850
(define-minor-mode footnote-mode
Chong Yidong's avatar
Chong Yidong committed
851 852
  "Toggle Footnote mode.

853
Footnote mode is a buffer-local minor mode.  If enabled, it
Chong Yidong's avatar
Chong Yidong committed
854 855
provides footnote support for `message-mode'.  To get started,
play around with the following keys:
856 857 858
\\{footnote-minor-mode-map}"
  :lighter    footnote-mode-line-string
  :keymap     footnote-minor-mode-map
Dave Love's avatar
Dave Love committed
859
  ;; (filladapt-mode t)
860 861 862 863 864
  (unless adaptive-fill-function
    ;; nil and `ignore' have the same semantics for adaptive-fill-function,
    ;; but only `ignore' behaves correctly with add/remove-function.
    (setq adaptive-fill-function #'ignore))
  (remove-function (local 'adaptive-fill-function)
865
                   #'footnote--adaptive-fill-function)
Dave Love's avatar
Dave Love committed
866
  (when footnote-mode
867
    ;; (footnote-setup-keybindings)
Chong Yidong's avatar
Chong Yidong committed
868
    (make-local-variable 'footnote-style)
869 870 871 872 873 874
    (make-local-variable 'footnote-body-tag-spacing)
    (make-local-variable 'footnote-spaced-footnotes)
    (make-local-variable 'footnote-section-tag)
    (make-local-variable 'footnote-section-tag-regexp)
    (make-local-variable 'footnote-start-tag)
    (make-local-variable 'footnote-end-tag)
875 876
    (make-local-variable 'adaptive-fill-function)
    (add-function :around (local 'adaptive-fill-function)
877
                  #'footnote--adaptive-fill-function)
Dave Love's avatar
Dave Love committed
878

879
    ;; Filladapt was an XEmacs package which is now in GNU ELPA.
Dave Love's avatar
Dave Love committed
880 881 882 883 884 885 886 887 888 889 890
    (when (boundp 'filladapt-token-table)
      ;; add tokens to filladapt to match footnotes
      ;; 1] xxxxxxxxxxx x x x or [1] x x x x x x x
      ;;    xxx x xx xxx xxxx	     x x x xxxxxxxxxx
      (let ((bullet-regexp (concat (regexp-quote footnote-start-tag)
				   "?[0-9a-zA-Z]+"
				   (regexp-quote footnote-end-tag)
				   "[ \t]")))
	(unless (assoc bullet-regexp filladapt-token-table)
	  (setq filladapt-token-table
		(append filladapt-token-table
891
			(list (list bullet-regexp 'bullet)))))))))
Dave Love's avatar
Dave Love committed
892 893 894 895

(provide 'footnote)

;;; footnote.el ends here