aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorStefan Merten2016-07-31 16:40:46 +0200
committerStefan Merten2016-07-31 16:40:46 +0200
commitcafb4a391b74e193d5807348fb3ee849c6acdde9 (patch)
tree3514d31f67798efd8c95ee45f28907d45ac7b506
parent8cbaf342538fe49f6f064f65717672f8eeb83750 (diff)
downloademacs-cafb4a391b74e193d5807348fb3ee849c6acdde9.tar.gz
emacs-cafb4a391b74e193d5807348fb3ee849c6acdde9.zip
* lisp/textmodes/rst.el: Major refactoring, minor changes, minor fixes
(rst-Ado, rst-Hdr, rst-Ttl, rst-Stn): Introduce classes representing reStructuredText section header concepts. (rst-mode-map, rst-new-preferred-hdr) (rst-update-section, rst-classify-adornment) (rst-ttl-at-point, rst-all-ttls-cache) (rst-hdr-hierarchy-cache, rst-reset-section-caches) (rst-all-ttls, rst-infer-hdr-hierarchy, rst-hdr-hierarchy) (rst-all-ttls-with-level, rst-get-previous-hdr) (rst-adornment-complete-p, rst-next-hdr, rst-adjust) (rst-adjust-section, rst-promote-region) (rst-display-hdr-hierarchy, rst-straighten-sections) (rst-all-stn, rst-remaining-stn, rst-toc-insert) (rst-toc-insert-node, rst-toc-node, rst-toc) (rst-forward-section, rst-adornment-level) (rst-font-lock-handle-adornment-pre-match-form) (rst-imenu-convert-cell, rst-imenu-create-index): Refactor using classes. (rst-compare-adornments, rst-get-adornment-match): Remove functions now in classes. (rst-re-alist-def, rst-toc-mode) (rst-font-lock-extend-region-extend): Minor improvements. (rst-mode, rst-compile): Use `setq-local'. (rst-cvs-header, rst-svn-rev, rst-svn-timestamp) (rst-official-version, rst-official-cvs-rev) (rst-package-emacs-version-alist): Maintain version tags.
-rw-r--r--lisp/textmodes/rst.el2772
1 files changed, 1558 insertions, 1214 deletions
diff --git a/lisp/textmodes/rst.el b/lisp/textmodes/rst.el
index 3d4854e89d6..ed2075caca0 100644
--- a/lisp/textmodes/rst.el
+++ b/lisp/textmodes/rst.el
@@ -2,8 +2,8 @@
2 2
3;; Copyright (C) 2003-2016 Free Software Foundation, Inc. 3;; Copyright (C) 2003-2016 Free Software Foundation, Inc.
4 4
5;; Maintainer: Stefan Merten <smerten@oekonux.de> 5;; Maintainer: Stefan Merten <stefan at merten-home dot de>
6;; Author: Stefan Merten <smerten@oekonux.de>, 6;; Author: Stefan Merten <stefan at merten-home dot de>,
7;; Martin Blais <blais@furius.ca>, 7;; Martin Blais <blais@furius.ca>,
8;; David Goodger <goodger@python.org>, 8;; David Goodger <goodger@python.org>,
9;; Wei-Wei Guo <wwguocn@gmail.com> 9;; Wei-Wei Guo <wwguocn@gmail.com>
@@ -53,10 +53,10 @@
53;; For full details on how to use the contents of this file, see 53;; For full details on how to use the contents of this file, see
54;; http://docutils.sourceforge.net/docs/user/emacs.html 54;; http://docutils.sourceforge.net/docs/user/emacs.html
55;; 55;;
56;; 56;; There are a number of convenient key bindings provided by rst-mode. For the
57;; There are a number of convenient key bindings provided by rst-mode. 57;; bindings, try C-c C-h when in rst-mode. There are also many variables that
58;; For more on bindings, see rst-mode-map below. There are also many variables 58;; can be customized, look for defcustom in this file or look for the "rst"
59;; that can be customized, look for defcustom in this file. 59;; customization group contained in the "wp" group.
60;; 60;;
61;; If you use the table-of-contents feature, you may want to add a hook to 61;; If you use the table-of-contents feature, you may want to add a hook to
62;; update the TOC automatically every time you adjust a section title:: 62;; update the TOC automatically every time you adjust a section title::
@@ -68,11 +68,6 @@
68;; 68;;
69;; (setq font-lock-global-modes '(not rst-mode ...)) 69;; (setq font-lock-global-modes '(not rst-mode ...))
70;; 70;;
71;;
72;;
73;; Customization is done by customizable variables contained in customization
74;; group "rst" and subgroups. Group "rst" is contained in the "wp" group.
75;;
76 71
77;;; DOWNLOAD 72;;; DOWNLOAD
78 73
@@ -110,10 +105,10 @@
110;; FIXME: When 24.1 is common place remove use of `lexical-let' and put "-*- 105;; FIXME: When 24.1 is common place remove use of `lexical-let' and put "-*-
111;; lexical-binding: t -*-" in the first line. 106;; lexical-binding: t -*-" in the first line.
112 107
113;; FIXME: Use `testcover'. 108;; FIXME: Embed complicated `defconst's in `eval-when-compile'.
114 109
115;; FIXME: The adornment classification often called `ado' should be a 110;; FIXME: Use `testcover'. Mark up a function with sufficient test coverage by
116;; `defstruct'. 111;; a comment tagged with `testcover' after the `defun'.
117 112
118;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 113;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
119;; Support for `testcover' 114;; Support for `testcover'
@@ -160,6 +155,7 @@ considered constants. Revert it with this function after each `defcustom'."
160;; used from there. 155;; used from there.
161 156
162(defun rst-signum (x) 157(defun rst-signum (x)
158 ;; testcover: ok.
163 "Return 1 if X is positive, -1 if negative, 0 if zero." 159 "Return 1 if X is positive, -1 if negative, 0 if zero."
164 (cond 160 (cond
165 ((> x 0) 1) 161 ((> x 0) 1)
@@ -167,6 +163,7 @@ considered constants. Revert it with this function after each `defcustom'."
167 (t 0))) 163 (t 0)))
168 164
169(defun rst-some (seq &optional pred) 165(defun rst-some (seq &optional pred)
166 ;; testcover: ok.
170 "Return non-nil if any element of SEQ yields non-nil when PRED is applied. 167 "Return non-nil if any element of SEQ yields non-nil when PRED is applied.
171Apply PRED to each element of list SEQ until the first non-nil 168Apply PRED to each element of list SEQ until the first non-nil
172result is yielded and return this result. PRED defaults to 169result is yielded and return this result. PRED defaults to
@@ -180,6 +177,7 @@ result is yielded and return this result. PRED defaults to
180 (throw 'rst-some r)))))) 177 (throw 'rst-some r))))))
181 178
182(defun rst-position-if (pred seq) 179(defun rst-position-if (pred seq)
180 ;; testcover: ok.
183 "Return position of first element satisfying PRED in list SEQ or nil." 181 "Return position of first element satisfying PRED in list SEQ or nil."
184 (catch 'rst-position-if 182 (catch 'rst-position-if
185 (let ((i 0)) 183 (let ((i 0))
@@ -189,6 +187,7 @@ result is yielded and return this result. PRED defaults to
189 (incf i))))) 187 (incf i)))))
190 188
191(defun rst-position (elem seq) 189(defun rst-position (elem seq)
190 ;; testcover: ok.
192 "Return position of ELEM in list SEQ or nil. 191 "Return position of ELEM in list SEQ or nil.
193Comparison done with `equal'." 192Comparison done with `equal'."
194 ;; Create a closure containing `elem' so the `lambda' always sees our 193 ;; Create a closure containing `elem' so the `lambda' always sees our
@@ -199,13 +198,22 @@ Comparison done with `equal'."
199 (equal elem e))) 198 (equal elem e)))
200 seq))) 199 seq)))
201 200
202;; FIXME: Embed complicated `defconst's in `eval-when-compile'. 201(defun rst-member-if (pred seq)
202 ;; testcover: ok.
203 "Return sublist of SEQ starting with the element whose car satisfies PRED."
204 (let (found)
205 (while (and (not found) seq)
206 (if (funcall pred (car seq))
207 (setq found seq)
208 (setq seq (cdr seq))))
209 found))
203 210
211
204;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 212;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
205;; Versions 213;; Versions
206 214
207;; testcover: ok.
208(defun rst-extract-version (delim-re head-re re tail-re var &optional default) 215(defun rst-extract-version (delim-re head-re re tail-re var &optional default)
216 ;; testcover: ok.
209 "Extract the version from a variable according to the given regexes. 217 "Extract the version from a variable according to the given regexes.
210Return the version after regex DELIM-RE and HEAD-RE matching RE 218Return the version after regex DELIM-RE and HEAD-RE matching RE
211and before TAIL-RE and DELIM-RE in VAR or DEFAULT for no match." 219and before TAIL-RE and DELIM-RE in VAR or DEFAULT for no match."
@@ -218,7 +226,7 @@ and before TAIL-RE and DELIM-RE in VAR or DEFAULT for no match."
218;; Use CVSHeader to really get information from CVS and not other version 226;; Use CVSHeader to really get information from CVS and not other version
219;; control systems. 227;; control systems.
220(defconst rst-cvs-header 228(defconst rst-cvs-header
221 "$CVSHeader: sm/rst_el/rst.el,v 1.327.2.26 2015/10/04 09:26:04 stefan Exp $") 229 "$CVSHeader: sm/rst_el/rst.el,v 1.600 2016/07/31 11:13:44 stefan Exp $")
222(defconst rst-cvs-rev 230(defconst rst-cvs-rev
223 (rst-extract-version "\\$" "CVSHeader: \\S + " "[0-9]+\\(?:\\.[0-9]+\\)+" 231 (rst-extract-version "\\$" "CVSHeader: \\S + " "[0-9]+\\(?:\\.[0-9]+\\)+"
224 " .*" rst-cvs-header "0.0") 232 " .*" rst-cvs-header "0.0")
@@ -232,22 +240,22 @@ and before TAIL-RE and DELIM-RE in VAR or DEFAULT for no match."
232;; Use LastChanged... to really get information from SVN. 240;; Use LastChanged... to really get information from SVN.
233(defconst rst-svn-rev 241(defconst rst-svn-rev
234 (rst-extract-version "\\$" "LastChangedRevision: " "[0-9]+" " " 242 (rst-extract-version "\\$" "LastChangedRevision: " "[0-9]+" " "
235 "$LastChangedRevision: 7925 $") 243 "$LastChangedRevision: 7963 $")
236 "The SVN revision of this file. 244 "The SVN revision of this file.
237SVN revision is the upstream (docutils) revision.") 245SVN revision is the upstream (docutils) revision.")
238(defconst rst-svn-timestamp 246(defconst rst-svn-timestamp
239 (rst-extract-version "\\$" "LastChangedDate: " ".+?+" " " 247 (rst-extract-version "\\$" "LastChangedDate: " ".+?+" " "
240 "$LastChangedDate: 2015-10-04 11:21:35 +0200 (Sun, 04 Oct 2015) $") 248 "$LastChangedDate: 2016-07-31 13:13:21 +0200 (Sun, 31 Jul 2016) $")
241 "The SVN time stamp of this file.") 249 "The SVN time stamp of this file.")
242 250
243;; Maintained by the release process. 251;; Maintained by the release process.
244(defconst rst-official-version 252(defconst rst-official-version
245 (rst-extract-version "%" "OfficialVersion: " "[0-9]+\\(?:\\.[0-9]+\\)+" " " 253 (rst-extract-version "%" "OfficialVersion: " "[0-9]+\\(?:\\.[0-9]+\\)+" " "
246 "%OfficialVersion: 1.4.1 %") 254 "%OfficialVersion: 1.5.0 %")
247 "Official version of the package.") 255 "Official version of the package.")
248(defconst rst-official-cvs-rev 256(defconst rst-official-cvs-rev
249 (rst-extract-version "[%$]" "Revision: " "[0-9]+\\(?:\\.[0-9]+\\)+" " " 257 (rst-extract-version "[%$]" "Revision: " "[0-9]+\\(?:\\.[0-9]+\\)+" " "
250 "%Revision: 1.327.2.25 %") 258 "%Revision: 1.600 %")
251 "CVS revision of this file in the official version.") 259 "CVS revision of this file in the official version.")
252 260
253(defconst rst-version 261(defconst rst-version
@@ -268,6 +276,8 @@ in parentheses follows the development revision and the time stamp.")
268 ("1.3.1" . "24.3") 276 ("1.3.1" . "24.3")
269 ("1.4.0" . "24.3") 277 ("1.4.0" . "24.3")
270 ("1.4.1" . "24.5") 278 ("1.4.1" . "24.5")
279 ("1.4.2" . "24.5")
280 ("1.5.0" . "25.2")
271 )) 281 ))
272 282
273(unless (assoc rst-official-version rst-package-emacs-version-alist) 283(unless (assoc rst-official-version rst-package-emacs-version-alist)
@@ -277,10 +287,10 @@ in parentheses follows the development revision and the time stamp.")
277(add-to-list 'customize-package-emacs-version-alist 287(add-to-list 'customize-package-emacs-version-alist
278 (cons 'ReST rst-package-emacs-version-alist)) 288 (cons 'ReST rst-package-emacs-version-alist))
279 289
290
280;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 291;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
281;; Initialize customization 292;; Initialize customization
282 293
283
284(defgroup rst nil "Support for reStructuredText documents." 294(defgroup rst nil "Support for reStructuredText documents."
285 :group 'wp 295 :group 'wp
286 :version "23.1" 296 :version "23.1"
@@ -490,8 +500,10 @@ in parentheses follows the development revision and the time stamp.")
490 ; character. 500 ; character.
491 501
492 ;; Titles (`ttl') 502 ;; Titles (`ttl')
493 (ttl-tag "\\S *\\w\\S *") ; A title text. 503 (ttl-tag "\\S *\\w.*\\S ") ; A title text.
494 (ttl-beg lin-beg ttl-tag) ; A title text at the beginning of a line. 504 (ttl-beg-1 lin-beg (:grp ttl-tag)) ; A title text at the beginning of a
505 ; line. First group is the complete,
506 ; trimmed title text.
495 507
496 ;; Directives and substitution definitions (`dir') 508 ;; Directives and substitution definitions (`dir')
497 (dir-tag-3 (:grp exm-sta) 509 (dir-tag-3 (:grp exm-sta)
@@ -531,8 +543,8 @@ argument list for `rst-re'.")
531 543
532;; FIXME: Use `sregex' or `rx' instead of re-inventing the wheel. 544;; FIXME: Use `sregex' or `rx' instead of re-inventing the wheel.
533(rst-testcover-add-compose 'rst-re) 545(rst-testcover-add-compose 'rst-re)
534;; testcover: ok.
535(defun rst-re (&rest args) 546(defun rst-re (&rest args)
547 ;; testcover: ok.
536 "Interpret ARGS as regular expressions and return a regex string. 548 "Interpret ARGS as regular expressions and return a regex string.
537Each element of ARGS may be one of the following: 549Each element of ARGS may be one of the following:
538 550
@@ -603,10 +615,579 @@ After interpretation of ARGS the results are concatenated as for
603 615
604 616
605;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 617;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
618;; Concepts
619
620;; Each of the following classes represents an own concept. The suffix of the
621;; class name is used in the code to represent entities of the respective
622;; class.
623;;
624;; In addition a reStructuredText section header in the buffer is called
625;; "section".
626;;
627;; For lists a "s" is added to the name of the concepts.
628
629
630;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
631;; Class rst-Ado
632
633(defstruct
634 (rst-Ado
635 (:constructor nil) ;; Prevent creating unchecked values.
636 ;; Construct a transition.
637 (:constructor
638 rst-Ado-new-transition
639 (&aux
640 (char nil)
641 (-style 'transition)))
642 ;; Construct a simple section header.
643 (:constructor
644 rst-Ado-new-simple
645 (char-arg
646 &aux
647 (char (rst-Ado--validate-char char-arg))
648 (-style 'simple)))
649 ;; Construct a over-and-under section header.
650 (:constructor
651 rst-Ado-new-over-and-under
652 (char-arg
653 &aux
654 (char (rst-Ado--validate-char char-arg))
655 (-style 'over-and-under)))
656 ;; Construct from adornment with inverted style.
657 (:constructor
658 rst-Ado-new-invert
659 (ado-arg
660 &aux
661 (char (rst-Ado-char ado-arg))
662 (-style (let ((sty (rst-Ado--style ado-arg)))
663 (cond
664 ((eq sty 'simple)
665 'over-and-under)
666 ((eq sty 'over-and-under)
667 'simple)
668 (sty)))))))
669 "Representation of a reStructuredText adornment.
670Adornments are either section markers where they markup the
671section header or transitions.
672
673This type is immutable."
674 ;; The character used for the adornment.
675 (char nil :read-only t)
676 ;; The style of the adornment. This is a private attribute.
677 (-style nil :read-only t))
678
679;; Private class methods
680
681(defun rst-Ado--validate-char (char)
682 ;; testcover: ok.
683 "Validate CHAR to be a valid adornment character.
684Return CHAR if so or signal an error otherwise."
685 (cond
686 ((not (characterp char))
687 (signal 'wrong-type-argument (list 'characterp char)))
688 ((memq char rst-adornment-chars)
689 char)
690 (t
691 (signal 'args-out-of-range
692 (list (format
693 "Character must be a valid adornment character, not '%s'"
694 char))))))
695
696;; Public methods
697
698(defun rst-Ado-is-transition (self)
699 ;; testcover: ok.
700 "Return non-nil if SELF is a transition adornment."
701 (unless (rst-Ado-p self)
702 (signal 'wrong-type-argument
703 (list 'rst-Ado-p self)))
704 (eq (rst-Ado--style self) 'transition))
705
706(defun rst-Ado-is-section (self)
707 ;; testcover: ok.
708 "Return non-nil if SELF is a section adornment."
709 (unless (rst-Ado-p self)
710 (signal 'wrong-type-argument
711 (list 'rst-Ado-p self)))
712 (not (rst-Ado-is-transition self)))
713
714(defun rst-Ado-is-simple (self)
715 ;; testcover: ok.
716 "Return non-nil if SELF is a simple section adornment."
717 (unless (rst-Ado-p self)
718 (signal 'wrong-type-argument
719 (list 'rst-Ado-p self)))
720 (eq (rst-Ado--style self) 'simple))
721
722(defun rst-Ado-is-over-and-under (self)
723 ;; testcover: ok.
724 "Return non-nil if SELF is a over-and-under section adornment."
725 (unless (rst-Ado-p self)
726 (signal 'wrong-type-argument
727 (list 'rst-Ado-p self)))
728 (eq (rst-Ado--style self) 'over-and-under))
729
730(defun rst-Ado-equal (self other)
731 ;; testcover: ok.
732 "Return non-nil when SELF and OTHER are equal."
733 (cond
734 ((not (rst-Ado-p self))
735 (signal 'wrong-type-argument
736 (list 'rst-Ado-p self)))
737 ((not (rst-Ado-p other))
738 (signal 'wrong-type-argument
739 (list 'rst-Ado-p other)))
740 ((not (eq (rst-Ado--style self) (rst-Ado--style other)))
741 nil)
742 ((rst-Ado-is-transition self))
743 ((equal (rst-Ado-char self) (rst-Ado-char other)))))
744
745(defun rst-Ado-position (self ados)
746 ;; testcover: ok.
747 "Return position of of SELF in ADOS or nil."
748 (unless (rst-Ado-p self)
749 (signal 'wrong-type-argument
750 (list 'rst-Ado-p self)))
751 (lexical-let ((ado self)) ;; Create closure.
752 (rst-position-if (function (lambda (e)
753 (rst-Ado-equal ado e)))
754 ados)))
755
756
757;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
758;; Class rst-Hdr
759
760(defstruct
761 (rst-Hdr
762 (:constructor nil) ;; Prevent creating unchecked values.
763 ;; Construct while all parameters must be valid.
764 (:constructor
765 rst-Hdr-new
766 (ado-arg
767 indent-arg
768 &aux
769 (ado (rst-Hdr--validate-ado ado-arg))
770 (indent (rst-Hdr--validate-indent indent-arg ado nil))))
771 ;; Construct while all parameters but `indent' must be valid.
772 (:constructor
773 rst-Hdr-new-lax
774 (ado-arg
775 indent-arg
776 &aux
777 (ado (rst-Hdr--validate-ado ado-arg))
778 (indent (rst-Hdr--validate-indent indent-arg ado t))))
779 ;; Construct a header with same characteristics but opposite style as `ado'.
780 (:constructor
781 rst-Hdr-new-invert
782 (ado-arg
783 indent-arg
784 &aux
785 (ado (rst-Hdr--validate-ado (rst-Ado-new-invert ado-arg)))
786 (indent (rst-Hdr--validate-indent indent-arg ado t))))
787 (:copier rst-Hdr-copy)) ;; Not really needed for an immutable type.
788 "Representation of reStructuredText section header characteristics.
789
790This type is immutable."
791 ;; The adornment of the header.
792 (ado nil :read-only t)
793 ;; The indentation of a title text or nil if not given.
794 (indent nil :read-only t))
795
796;; Private class methods
797
798(defun rst-Hdr--validate-indent (indent ado lax)
799 ;; testcover: ok.
800 "Validate INDENT to be a valid indentation for ADO.
801Return INDENT if so or signal an error otherwise. If LAX don't
802signal an error and return a valid indent."
803 (cond
804 ((not (integerp indent))
805 (signal 'wrong-type-argument
806 (list 'integerp 'null indent)))
807 ((zerop indent)
808 indent)
809 ((rst-Ado-is-simple ado)
810 (if lax
811 0
812 (signal 'args-out-of-range
813 '("Indentation must be 0 for style simple"))))
814 ((< indent 0)
815 (if lax
816 0
817 (signal 'args-out-of-range
818 '("Indentation must not be negative"))))
819 (indent))) ;; Implicitly over-and-under.
820
821(defun rst-Hdr--validate-ado (ado)
822 ;; testcover: ok.
823 "Validate ADO to be a valid adornment.
824Return ADO if so or signal an error otherwise."
825 (cond
826 ((not (rst-Ado-p ado))
827 (signal 'wrong-type-argument
828 (list 'rst-Ado-p ado)))
829 ((rst-Ado-is-transition ado)
830 (signal 'args-out-of-range
831 '("Adornment for header must not be transition.")))
832 (t
833 ado)))
834
835;; Public class methods
836
837(defun rst-Hdr-preferred-adornments ()
838 ;; testcover: ok.
839 "Return preferred adornments as list of `rst-Hdr'."
840 (mapcar (lambda (el)
841 (rst-Hdr-new-lax
842 (if (eq (cadr el) 'over-and-under)
843 (rst-Ado-new-over-and-under (car el))
844 (rst-Ado-new-simple (car el)))
845 (caddr el)))
846 rst-preferred-adornments))
847
848;; Public methods
849
850(defun rst-Hdr-member-ado (self hdrs)
851 ;; testcover: ok.
852 "Return sublist of HDRS whose car's adornment equals that of SELF or nil."
853 (unless (rst-Hdr-p self)
854 (signal 'wrong-type-argument
855 (list 'rst-Hdr-p self)))
856 (let ((pos (rst-Ado-position (rst-Hdr-ado self) (rst-Hdr-ado-map hdrs))))
857 (and pos (nthcdr pos hdrs))))
858
859(defun rst-Hdr-ado-map (selfs)
860 ;; testcover: ok.
861 "Return `rst-Ado' list extracted from elements of SELFS."
862 (mapcar 'rst-Hdr-ado selfs))
863
864(defun rst-Hdr-get-char (self)
865 ;; testcover: ok.
866 "Return character of the adornment of SELF."
867 (unless (rst-Hdr-p self)
868 (signal 'wrong-type-argument
869 (list 'rst-Hdr-p self)))
870 (rst-Ado-char (rst-Hdr-ado self)))
871
872(defun rst-Hdr-is-over-and-under (self)
873 ;; testcover: ok.
874 "Return non-nil if SELF is a over-and-under section header."
875 (unless (rst-Hdr-p self)
876 (signal 'wrong-type-argument
877 (list 'rst-Hdr-p self)))
878 (rst-Ado-is-over-and-under (rst-Hdr-ado self)))
879
880
881;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
882;; Class rst-Ttl
883
884(defstruct
885 (rst-Ttl
886 (:constructor nil) ;; Prevent creating unchecked values.
887 ;; Construct with valid parameters for all attributes.
888 (:constructor
889 rst-Ttl-new
890 (ado-arg
891 match-arg
892 indent-arg
893 text-arg
894 &optional
895 hdr-arg
896 level-arg
897 &aux
898 (ado (rst-Ttl--validate-ado ado-arg))
899 (match (rst-Ttl--validate-match match-arg ado))
900 (indent (rst-Ttl--validate-indent indent-arg ado))
901 (text (rst-Ttl--validate-text text-arg ado))
902 (hdr (and hdr-arg (rst-Ttl--validate-hdr hdr-arg ado indent)))
903 (level (and level-arg (rst-Ttl--validate-level level-arg)))))
904 (:copier rst-Ttl-copy))
905 "Representation of a reStructuredText section header as found in the buffer.
906This type gathers information about an adorned part in the
907buffer. Thus only the basic attributes are immutable. Although
908the remaining attributes are `setf'-able the respective setters
909should be used."
910 ;; The adornment characteristics or nil for a title candidate.
911 (ado nil :read-only t)
912 ;; The match-data for `ado' as returned by `match-data'. Match group 0
913 ;; matches the whole construct. Match group 1 matches the overline adornment
914 ;; if present. Match group 2 matches the section title text or the
915 ;; transition. Match group 3 matches the underline adornment.
916 (match nil :read-only t)
917 ;; An indentation found for the title line or nil for a transition.
918 (indent nil :read-only t)
919 ;; The text of the title or nil for a transition.
920 (text nil :read-only t)
921 ;; The header characteristics if it is a valid section header.
922 (hdr nil)
923 ;; The hierarchical level of the section header starting with 0.
924 (level nil))
925
926;; Private class methods
927
928(defun rst-Ttl--validate-ado (ado)
929 ;; testcover: ok.
930 "Return valid ADO or signal error."
931 (unless (or (null ado) (rst-Ado-p ado))
932 (signal 'wrong-type-argument
933 (list 'null 'rst-Ado-p ado)))
934 ado)
935
936(defun rst-Ttl--validate-match (match ado)
937 ;; testcover: ok.
938 "Return valid MATCH matching ADO or signal error."
939 (unless (listp match)
940 (signal 'wrong-type-argument
941 (list 'listp match)))
942 (unless (equal (length match) 8)
943 (signal 'args-out-of-range
944 '("Match data must consist of exactly 8 buffer positions.")))
945 (mapcar (lambda (pos)
946 (unless (or (null pos) (integer-or-marker-p pos))
947 (signal 'wrong-type-argument
948 (list 'integer-or-marker-p 'null pos))))
949 match)
950 (unless (and (integer-or-marker-p (nth 0 match))
951 (integer-or-marker-p (nth 1 match)))
952 (signal 'args-out-of-range
953 '("First two elements of match data must be buffer positions.")))
954 (cond
955 ((null ado)
956 (unless (and (null (nth 2 match))
957 (null (nth 3 match))
958 (integer-or-marker-p (nth 4 match))
959 (integer-or-marker-p (nth 5 match))
960 (null (nth 6 match))
961 (null (nth 7 match)))
962 (signal 'args-out-of-range
963 '("For a title candidate exactly the third match pair must be set."))))
964 ((rst-Ado-is-transition ado)
965 (unless (and (null (nth 2 match))
966 (null (nth 3 match))
967 (integer-or-marker-p (nth 4 match))
968 (integer-or-marker-p (nth 5 match))
969 (null (nth 6 match))
970 (null (nth 7 match)))
971 (signal 'args-out-of-range
972 '("For a transition exactly the third match pair must be set."))))
973 ((rst-Ado-is-simple ado)
974 (unless (and (null (nth 2 match))
975 (null (nth 3 match))
976 (integer-or-marker-p (nth 4 match))
977 (integer-or-marker-p (nth 5 match))
978 (integer-or-marker-p (nth 6 match))
979 (integer-or-marker-p (nth 7 match)))
980 (signal 'args-out-of-range
981 '("For a simple section adornment exactly the third and fourth match pair must be set."))))
982 (t ;; over-and-under
983 (unless (and (integer-or-marker-p (nth 2 match))
984 (integer-or-marker-p (nth 3 match))
985 (integer-or-marker-p (nth 4 match))
986 (integer-or-marker-p (nth 5 match))
987 (or (null (nth 6 match)) (integer-or-marker-p (nth 6 match)))
988 (or (null (nth 7 match)) (integer-or-marker-p (nth 7 match))))
989 (signal 'args-out-of-range
990 '("For a over-and-under section adornment all match pairs must be set.")))))
991 match)
992
993(defun rst-Ttl--validate-indent (indent ado)
994 ;; testcover: ok.
995 "Return valid INDENT for ADO or signal error."
996 (if (and ado (rst-Ado-is-transition ado))
997 (unless (null indent)
998 (signal 'args-out-of-range
999 '("Indent for a transition must be nil.")))
1000 (unless (integerp indent)
1001 (signal 'wrong-type-argument
1002 (list 'integerp indent)))
1003 (unless (>= indent 0)
1004 (signal 'args-out-of-range
1005 '("Indent for a section header must be non-negative."))))
1006 indent)
1007
1008(defun rst-Ttl--validate-hdr (hdr ado indent)
1009 ;; testcover: ok.
1010 "Return valid HDR in relation to ADO and INDENT or signal error."
1011 (unless (rst-Hdr-p hdr)
1012 (signal 'wrong-type-argument
1013 (list 'rst-Hdr-p hdr)))
1014 (unless (rst-Ado-equal (rst-Hdr-ado hdr) ado)
1015 (signal 'args-out-of-range
1016 '("Basic adornment and adornment in header must match.")))
1017 (unless (equal (rst-Hdr-indent hdr) indent)
1018 (signal 'args-out-of-range
1019 '("Basic indent and indent in header must match.")))
1020 hdr)
1021
1022(defun rst-Ttl--validate-text (text ado)
1023 ;; testcover: ok.
1024 "Return valid TEXT for ADO or signal error."
1025 (if (and ado (rst-Ado-is-transition ado))
1026 (unless (null text)
1027 (signal 'args-out-of-range
1028 '("Transitions may not have title text.")))
1029 (unless (stringp text)
1030 (signal 'wrong-type-argument
1031 (list 'stringp text))))
1032 text)
1033
1034(defun rst-Ttl--validate-level (level)
1035 ;; testcover: ok.
1036 "Return valid LEVEL or signal error."
1037 (unless (integerp level)
1038 (signal 'wrong-type-argument
1039 (list 'integerp level)))
1040 (unless (>= level 0)
1041 (signal 'args-out-of-range
1042 '("Level must be non-negative.")))
1043 level)
1044
1045;; Public methods
1046
1047(defun rst-Ttl-evaluate-hdr (self)
1048 ;; testcover: ok.
1049 "Check for `ado' and `indent' in SELF forming a valid `rst-Hdr'.
1050Set and return it or nil if no valid `rst-Hdr' can be formed."
1051 (setf (rst-Ttl-hdr self)
1052 (condition-case nil
1053 (rst-Hdr-new (rst-Ttl-ado self) (rst-Ttl-indent self))
1054 (error nil))))
1055
1056(defun rst-Ttl-set-level (self level)
1057 ;; testcover: ok.
1058 "In SELF set and return LEVEL or nil if invalid."
1059 (setf (rst-Ttl-level self)
1060 (rst-Ttl--validate-level level)))
1061
1062(defun rst-Ttl-get-title-beginning (self)
1063 ;; testcover: ok.
1064 "Return position of beginning of title text of SELF.
1065This position should always be at the start of a line."
1066 (nth 4 (rst-Ttl-match self)))
1067
1068(defun rst-Ttl-get-beginning (self)
1069 ;; testcover: ok.
1070 "Return position of beginning of whole SELF."
1071 (nth 0 (rst-Ttl-match self)))
1072
1073(defun rst-Ttl-get-end (self)
1074 ;; testcover: ok.
1075 "Return position of end of whole SELF."
1076 (nth 1 (rst-Ttl-match self)))
1077
1078
1079;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1080;; Class rst-Stn
1081
1082(defstruct
1083 (rst-Stn
1084 (:constructor nil) ;; Prevent creating unchecked values.
1085 ;; Construct while all parameters must be valid.
1086 (:constructor
1087 rst-Stn-new
1088 (ttl-arg
1089 level-arg
1090 children-arg
1091 &aux
1092 (ttl (rst-Stn--validate-ttl ttl-arg))
1093 (level (rst-Stn--validate-level level-arg ttl))
1094 (children (rst-Stn--validate-children children-arg ttl)))))
1095 "Representation of a section tree node.
1096
1097This type is immutable."
1098 ;; The title of the node or nil for a missing node.
1099 (ttl nil :read-only t)
1100 ;; The level of the node in the tree. Negative for the (virtual) top level
1101 ;; node.
1102 (level nil :read-only t)
1103 ;; The list of children of the node.
1104 (children nil :read-only t))
1105
1106;; Private class methods
1107
1108(defun rst-Stn--validate-ttl (ttl)
1109 ;; testcover: ok.
1110 "Return valid TTL or signal error."
1111 (unless (or (null ttl) (rst-Ttl-p ttl))
1112 (signal 'wrong-type-argument
1113 (list 'null 'rst-Ttl-p ttl)))
1114 ttl)
1115
1116(defun rst-Stn--validate-level (level ttl)
1117 ;; testcover: ok.
1118 "Return valid LEVEL for TTL or signal error."
1119 (unless (integerp level)
1120 (signal 'wrong-type-argument
1121 (list 'integerp level)))
1122 (when ttl
1123 (unless (or (not (rst-Ttl-level ttl))
1124 (equal (rst-Ttl-level ttl) level))
1125 (signal 'args-out-of-range
1126 '("A title must have correct level or none at all.")))
1127 (when (< level 0)
1128 ;; testcover: Never reached because a title may not have a negative level
1129 (signal 'args-out-of-range
1130 '("Top level node must not have a title."))))
1131 level)
1132
1133(defun rst-Stn--validate-children (children ttl)
1134 ;; testcover: ok.
1135 "Return valid CHILDREN for TTL or signal error."
1136 (unless (listp children)
1137 (signal 'wrong-type-argument
1138 (list 'listp children)))
1139 (mapcar (lambda (child)
1140 (unless (rst-Stn-p child)
1141 (signal 'wrong-type-argument
1142 (list 'rst-Stn-p child))))
1143 children)
1144 (unless (or ttl children)
1145 (signal 'args-out-of-range
1146 '("A missing node must have children.")))
1147 children)
1148
1149;; Public methods
1150
1151(defun rst-Stn-get-title-beginning (self)
1152 ;; testcover: ok.
1153 "Return the beginning of the title of SELF.
1154Handles missing node properly."
1155 (unless (rst-Stn-p self)
1156 (signal 'wrong-type-argument
1157 (list 'rst-Stn-p self)))
1158 (let ((ttl (rst-Stn-ttl self)))
1159 (if ttl
1160 (rst-Ttl-get-title-beginning ttl)
1161 (rst-Stn-get-title-beginning (car (rst-Stn-children self))))))
1162
1163(defun rst-Stn-get-text (self &optional default)
1164 ;; testcover: ok.
1165 "Return title text of SELF or DEFAULT if SELF is a missing node.
1166For a missing node and no DEFAULT given return a standard title text."
1167 (unless (rst-Stn-p self)
1168 (signal 'wrong-type-argument
1169 (list 'rst-Stn-p self)))
1170 (let ((ttl (rst-Stn-ttl self)))
1171 (cond
1172 (ttl
1173 (rst-Ttl-text ttl))
1174 (default)
1175 ("[missing node]"))))
1176
1177(defun rst-Stn-is-top (self)
1178 ;; testcover: ok.
1179 "Return non-nil if SELF is a top level node."
1180 (unless (rst-Stn-p self)
1181 (signal 'wrong-type-argument
1182 (list 'rst-Stn-p self)))
1183 (< (rst-Stn-level self) 0))
1184
1185
1186;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
606;; Mode definition 1187;; Mode definition
607 1188
608;; testcover: ok.
609(defun rst-define-key (keymap key def &rest deprecated) 1189(defun rst-define-key (keymap key def &rest deprecated)
1190 ;; testcover: ok.
610 "Bind like `define-key' but add deprecated key definitions. 1191 "Bind like `define-key' but add deprecated key definitions.
611KEYMAP, KEY, and DEF are as in `define-key'. DEPRECATED key 1192KEYMAP, KEY, and DEF are as in `define-key'. DEPRECATED key
612definitions should be in vector notation. These are defined 1193definitions should be in vector notation. These are defined
@@ -618,7 +1199,7 @@ as well but give an additional message."
618 (if (string-match "^rst-\\(.*\\)$" command-name) 1199 (if (string-match "^rst-\\(.*\\)$" command-name)
619 (concat "rst-deprecated-" 1200 (concat "rst-deprecated-"
620 (match-string 1 command-name)) 1201 (match-string 1 command-name))
621 (error "not an RST command: %s" command-name))) 1202 (error "Not an RST command: %s" command-name)))
622 (forwarder-function (intern forwarder-function-name))) 1203 (forwarder-function (intern forwarder-function-name)))
623 (unless (fboundp forwarder-function) 1204 (unless (fboundp forwarder-function)
624 (defalias forwarder-function 1205 (defalias forwarder-function
@@ -633,6 +1214,7 @@ as well but give an additional message."
633 def def))) 1214 def def)))
634 (dolist (dep-key deprecated) 1215 (dolist (dep-key deprecated)
635 (define-key keymap dep-key forwarder-function))))) 1216 (define-key keymap dep-key forwarder-function)))))
1217
636 ;; Key bindings. 1218 ;; Key bindings.
637(defvar rst-mode-map 1219(defvar rst-mode-map
638 (let ((map (make-sparse-keymap))) 1220 (let ((map (make-sparse-keymap)))
@@ -654,9 +1236,9 @@ as well but give an additional message."
654 (rst-define-key map [?\C-c ?\C-a ?\C-a] 'rst-adjust) 1236 (rst-define-key map [?\C-c ?\C-a ?\C-a] 'rst-adjust)
655 ;; Display the hierarchy of adornments implied by the current document 1237 ;; Display the hierarchy of adornments implied by the current document
656 ;; contents. 1238 ;; contents.
657 (rst-define-key map [?\C-c ?\C-a ?\C-d] 'rst-display-adornments-hierarchy) 1239 (rst-define-key map [?\C-c ?\C-a ?\C-d] 'rst-display-hdr-hierarchy)
658 ;; Homogenize the adornments in the document. 1240 ;; Homogenize the adornments in the document.
659 (rst-define-key map [?\C-c ?\C-a ?\C-s] 'rst-straighten-adornments 1241 (rst-define-key map [?\C-c ?\C-a ?\C-s] 'rst-straighten-sections
660 [?\C-c ?\C-s]) 1242 [?\C-c ?\C-s])
661 1243
662 ;; 1244 ;;
@@ -818,71 +1400,62 @@ highlighting.
818 :group 'rst 1400 :group 'rst
819 1401
820 ;; Paragraph recognition. 1402 ;; Paragraph recognition.
821 (set (make-local-variable 'paragraph-separate) 1403 (setq-local paragraph-separate
822 (rst-re '(:alt 1404 (rst-re '(:alt
823 "\f" 1405 "\f"
824 lin-end))) 1406 lin-end)))
825 (set (make-local-variable 'paragraph-start) 1407 (setq-local paragraph-start
826 (rst-re '(:alt 1408 (rst-re '(:alt
827 "\f" 1409 "\f"
828 lin-end 1410 lin-end
829 (:seq hws-tag par-tag- bli-sfx)))) 1411 (:seq hws-tag par-tag- bli-sfx))))
830 1412
831 ;; Indenting and filling. 1413 ;; Indenting and filling.
832 (set (make-local-variable 'indent-line-function) 'rst-indent-line) 1414 (setq-local indent-line-function 'rst-indent-line)
833 (set (make-local-variable 'adaptive-fill-mode) t) 1415 (setq-local adaptive-fill-mode t)
834 (set (make-local-variable 'adaptive-fill-regexp) 1416 (setq-local adaptive-fill-regexp (rst-re 'hws-tag 'par-tag- "?" 'hws-tag))
835 (rst-re 'hws-tag 'par-tag- "?" 'hws-tag)) 1417 (setq-local adaptive-fill-function 'rst-adaptive-fill)
836 (set (make-local-variable 'adaptive-fill-function) 'rst-adaptive-fill) 1418 (setq-local fill-paragraph-handle-comment nil)
837 (set (make-local-variable 'fill-paragraph-handle-comment) nil)
838 1419
839 ;; Comments. 1420 ;; Comments.
840 (set (make-local-variable 'comment-start) ".. ") 1421 (setq-local comment-start ".. ")
841 (set (make-local-variable 'comment-start-skip) 1422 (setq-local comment-start-skip (rst-re 'lin-beg 'exm-tag 'bli-sfx))
842 (rst-re 'lin-beg 'exm-tag 'bli-sfx)) 1423 (setq-local comment-continue " ")
843 (set (make-local-variable 'comment-continue) " ") 1424 (setq-local comment-multi-line t)
844 (set (make-local-variable 'comment-multi-line) t) 1425 (setq-local comment-use-syntax nil)
845 (set (make-local-variable 'comment-use-syntax) nil)
846 ;; reStructuredText has not really a comment ender but nil is not really a 1426 ;; reStructuredText has not really a comment ender but nil is not really a
847 ;; permissible value. 1427 ;; permissible value.
848 (set (make-local-variable 'comment-end) "") 1428 (setq-local comment-end "")
849 (set (make-local-variable 'comment-end-skip) nil) 1429 (setq-local comment-end-skip nil)
850 1430
851 ;; Commenting in reStructuredText is very special so use our own set of 1431 ;; Commenting in reStructuredText is very special so use our own set of
852 ;; functions. 1432 ;; functions.
853 (set (make-local-variable 'comment-line-break-function) 1433 (setq-local comment-line-break-function 'rst-comment-line-break)
854 'rst-comment-line-break) 1434 (setq-local comment-indent-function 'rst-comment-indent)
855 (set (make-local-variable 'comment-indent-function) 1435 (setq-local comment-insert-comment-function 'rst-comment-insert-comment)
856 'rst-comment-indent) 1436 (setq-local comment-region-function 'rst-comment-region)
857 (set (make-local-variable 'comment-insert-comment-function) 1437 (setq-local uncomment-region-function 'rst-uncomment-region)
858 'rst-comment-insert-comment) 1438
859 (set (make-local-variable 'comment-region-function) 1439 (setq-local electric-pair-pairs '((?\" . ?\") (?\* . ?\*) (?\` . ?\`)))
860 'rst-comment-region)
861 (set (make-local-variable 'uncomment-region-function)
862 'rst-uncomment-region)
863
864 (set (make-local-variable 'electric-pair-pairs)
865 '((?\" . ?\") (?\* . ?\*) (?\` . ?\`)))
866 1440
867 ;; Imenu and which function. 1441 ;; Imenu and which function.
868 ;; FIXME: Check documentation of `which-function' for alternative ways to 1442 ;; FIXME: Check documentation of `which-function' for alternative ways to
869 ;; determine the current function name. 1443 ;; determine the current function name.
870 (set (make-local-variable 'imenu-create-index-function) 1444 (setq-local imenu-create-index-function 'rst-imenu-create-index)
871 'rst-imenu-create-index)
872 1445
873 ;; Font lock. 1446 ;; Font lock.
874 (set (make-local-variable 'font-lock-defaults) 1447 (setq-local font-lock-defaults
875 '(rst-font-lock-keywords 1448 '(rst-font-lock-keywords
876 t nil nil nil 1449 t nil nil nil
877 (font-lock-multiline . t) 1450 (font-lock-multiline . t)
878 (font-lock-mark-block-function . mark-paragraph))) 1451 (font-lock-mark-block-function . mark-paragraph)))
879 (add-hook 'font-lock-extend-region-functions 'rst-font-lock-extend-region t) 1452 (add-hook 'font-lock-extend-region-functions 'rst-font-lock-extend-region t)
880 1453
881 ;; Text after a changed line may need new fontification. 1454 ;; Text after a changed line may need new fontification.
882 (set (make-local-variable 'jit-lock-contextually) t) 1455 (setq-local jit-lock-contextually t)
883 1456
884 ;; Indentation is not deterministic. 1457 ;; Indentation is not deterministic.
885 (setq electric-indent-inhibit t)) 1458 (setq-local electric-indent-inhibit t))
886 1459
887;;;###autoload 1460;;;###autoload
888(define-minor-mode rst-minor-mode 1461(define-minor-mode rst-minor-mode
@@ -908,38 +1481,14 @@ for modes derived from Text mode, like Mail mode."
908 1481
909 1482
910;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1483;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
911;; Section Adornment Adjustment 1484;; Section adornment adjustment
912;; ============================ 1485
913;;
914;; The following functions implement a smart automatic title sectioning feature. 1486;; The following functions implement a smart automatic title sectioning feature.
915;; The idea is that with the cursor sitting on a section title, we try to get as 1487;; The idea is that with the cursor sitting on a section title, we try to get as
916;; much information from context and try to do the best thing automatically. 1488;; much information from context and try to do the best thing automatically.
917;; This function can be invoked many times and/or with prefix argument to rotate 1489;; This function can be invoked many times and/or with prefix argument to rotate
918;; between the various sectioning adornments. 1490;; between the various sectioning adornments.
919;; 1491;;
920;; Definitions: the two forms of sectioning define semantically separate section
921;; levels. A sectioning ADORNMENT consists in:
922;;
923;; - a CHARACTER
924;;
925;; - a STYLE which can be either of 'simple' or 'over-and-under'.
926;;
927;; - an INDENT (meaningful for the over-and-under style only) which determines
928;; how many characters and over-and-under style is hanging outside of the
929;; title at the beginning and ending.
930;;
931;; Here are two examples of adornments (| represents the window border, column
932;; 0):
933;;
934;; |
935;; 1. char: '-' e |Some Title
936;; style: simple |----------
937;; |
938;; 2. char: '=' |==============
939;; style: over-and-under | Some Title
940;; indent: 2 |==============
941;; |
942;;
943;; Some notes: 1492;; Some notes:
944;; 1493;;
945;; - The underlining character that is used depends on context. The file is 1494;; - The underlining character that is used depends on context. The file is
@@ -948,7 +1497,7 @@ for modes derived from Text mode, like Mail mode."
948;; rotated among the existing section adornments. 1497;; rotated among the existing section adornments.
949;; 1498;;
950;; Note that when rotating the characters, if we come to the end of the 1499;; Note that when rotating the characters, if we come to the end of the
951;; hierarchy of adornments, the variable rst-preferred-adornments is 1500;; hierarchy of adornments, the variable `rst-preferred-adornments' is
952;; consulted to propose a new underline adornment, and if continued, we cycle 1501;; consulted to propose a new underline adornment, and if continued, we cycle
953;; the adornments all over again. Set this variable to nil if you want to 1502;; the adornments all over again. Set this variable to nil if you want to
954;; limit the underlining character propositions to the existing adornments in 1503;; limit the underlining character propositions to the existing adornments in
@@ -986,6 +1535,8 @@ for modes derived from Text mode, like Mail mode."
986 1535
987(define-obsolete-variable-alias 1536(define-obsolete-variable-alias
988 'rst-preferred-decorations 'rst-preferred-adornments "rst 1.0.0") 1537 'rst-preferred-decorations 'rst-preferred-adornments "rst 1.0.0")
1538;; FIXME: Default must match suggestion in
1539;; http://sphinx-doc.org/rest.html#sections for Python documentation.
989(defcustom rst-preferred-adornments '((?= over-and-under 1) 1540(defcustom rst-preferred-adornments '((?= over-and-under 1)
990 (?= simple 0) 1541 (?= simple 0)
991 (?- simple 0) 1542 (?- simple 0)
@@ -995,13 +1546,10 @@ for modes derived from Text mode, like Mail mode."
995 (?# simple 0) 1546 (?# simple 0)
996 (?@ simple 0)) 1547 (?@ simple 0))
997 "Preferred hierarchy of section title adornments. 1548 "Preferred hierarchy of section title adornments.
998
999A list consisting of lists of the form (CHARACTER STYLE INDENT). 1549A list consisting of lists of the form (CHARACTER STYLE INDENT).
1000CHARACTER is the character used. STYLE is one of the symbols 1550CHARACTER is the character used. STYLE is one of the symbols
1001`over-and-under' or `simple'. INDENT is an integer giving the 1551`over-and-under' or `simple'. INDENT is an integer giving the
1002wanted indentation for STYLE `over-and-under'. CHARACTER and 1552wanted indentation for STYLE `over-and-under'.
1003STYLE are always used when a section adornment is described.
1004In other places, t instead of a list stands for a transition.
1005 1553
1006This sequence is consulted to offer a new adornment suggestion 1554This sequence is consulted to offer a new adornment suggestion
1007when we rotate the underlines at the end of the existing 1555when we rotate the underlines at the end of the existing
@@ -1025,156 +1573,111 @@ file."
1025 :value 0)))) 1573 :value 0))))
1026(rst-testcover-defcustom) 1574(rst-testcover-defcustom)
1027 1575
1576;; FIXME: Rename this to `rst-over-and-under-default-indent' and set default to
1577;; 0 because the effect of 1 is probably surprising in the few cases
1578;; where this is used.
1579;; FIXME: A matching adornment style can be looked for in
1580;; `rst-preferred-adornments' and its indentation used before using this
1581;; variable.
1028(defcustom rst-default-indent 1 1582(defcustom rst-default-indent 1
1029 "Number of characters to indent the section title. 1583 "Number of characters to indent the section title.
1030 1584This is only used while toggling adornment styles when switching
1031This is used for when toggling adornment styles, when switching
1032from a simple adornment style to a over-and-under adornment 1585from a simple adornment style to a over-and-under adornment
1033style." 1586style. In addition this is used in cases where the adornments
1587found in the buffer are to be used but the indentation for
1588over-and-under adornments is inconsistent across the buffer."
1034 :group 'rst-adjust 1589 :group 'rst-adjust
1035 :type '(integer)) 1590 :type '(integer))
1036(rst-testcover-defcustom) 1591(rst-testcover-defcustom)
1037 1592
1038(defun rst-compare-adornments (ado1 ado2) 1593(defun rst-new-preferred-hdr (seen prev)
1039 "Compare adornments. 1594 ;; testcover: ok.
1040Return true if both ADO1 and ADO2 adornments are equal, 1595 "Return a new, preferred `rst-Hdr' different from all in SEEN.
1041according to restructured text semantics (only the character 1596PREV is the previous `rst-Hdr' in the buffer. If given the
1042and the style are compared, the indentation does not matter)." 1597search starts after this entry. Return nil if no new preferred
1043 (and (eq (car ado1) (car ado2)) 1598`rst-Hdr' can be found."
1044 (eq (cadr ado1) (cadr ado2)))) 1599 ;; All preferred adornments are candidates.
1045 1600 (let ((candidates
1046 1601 (append
1047(defun rst-get-adornment-match (hier ado) 1602 (if prev
1048 "Return the index (level) in hierarchy HIER of adornment ADO. 1603 ;; Start searching after the level of the previous adornment.
1049This basically just searches for the item using the appropriate 1604 (cdr (rst-Hdr-member-ado prev (rst-Hdr-preferred-adornments))))
1050comparison and returns the index. Return nil if the item is 1605 (rst-Hdr-preferred-adornments))))
1051not found." 1606 (car
1052 (let ((cur hier)) 1607 (rst-member-if (lambda (cand)
1053 (while (and cur (not (rst-compare-adornments (car cur) ado))) 1608 (not (rst-Hdr-member-ado cand seen)))
1054 (setq cur (cdr cur))) 1609 candidates))))
1055 cur))
1056
1057;; testcover: FIXME: Test with `rst-preferred-adornments' == nil. Add test
1058;; `rst-adjust-no-preference'.
1059(defun rst-suggest-new-adornment (allados &optional prev)
1060 "Suggest a new, different adornment from all that have been seen.
1061
1062ALLADOS is the set of all adornments, including the line numbers.
1063PREV is the optional previous adornment, in order to suggest a
1064better match."
1065
1066 ;; For all the preferred adornments...
1067 (let* (
1068 ;; If 'prev' is given, reorder the list to start searching after the
1069 ;; match.
1070 (fplist
1071 (cdr (rst-get-adornment-match rst-preferred-adornments prev)))
1072
1073 ;; List of candidates to search.
1074 (curpotential (append fplist rst-preferred-adornments)))
1075 (while
1076 ;; For all the adornments...
1077 (let ((cur allados)
1078 found)
1079 (while (and cur (not found))
1080 (if (rst-compare-adornments (car cur) (car curpotential))
1081 ;; Found it!
1082 (setq found (car curpotential))
1083 (setq cur (cdr cur))))
1084 found)
1085
1086 (setq curpotential (cdr curpotential)))
1087
1088 (copy-sequence (car curpotential))))
1089 1610
1090(defun rst-delete-entire-line () 1611(defun rst-delete-entire-line ()
1091 "Delete the entire current line without using the `kill-ring'." 1612 "Delete the entire current line without using the `kill-ring'."
1092 (delete-region (line-beginning-position) 1613 (delete-region (line-beginning-position)
1093 (line-beginning-position 2))) 1614 (line-beginning-position 2)))
1094 1615
1095(defun rst-update-section (char style &optional indent) 1616(defun rst-update-section (hdr)
1096 "Unconditionally update the style of a section adornment. 1617 "Unconditionally update the style of the section header at point to HDR.
1097
1098Do this using the given character CHAR, with STYLE `simple'
1099or `over-and-under', and with indent INDENT. If the STYLE
1100is `simple', whitespace before the title is removed (indent
1101is always assumed to be 0).
1102
1103If there are existing overline and/or underline from the 1618If there are existing overline and/or underline from the
1104existing adornment, they are removed before adding the 1619existing adornment, they are removed before adding the
1105requested adornment." 1620requested adornment."
1106 (end-of-line) 1621 (end-of-line)
1107 (let ((marker (point-marker)) 1622 (let ((indent (or (rst-Hdr-indent hdr) 0))
1108 len) 1623 (marker (point-marker))
1624 len)
1109 1625
1110 ;; Fixup whitespace at the beginning and end of the line. 1626 ;; Fixup whitespace at the beginning and end of the line.
1111 (if (or (null indent) (eq style 'simple)) ;; testcover: ok. 1627 (beginning-of-line)
1112 (setq indent 0)) 1628 (delete-horizontal-space)
1113 (beginning-of-line) 1629 (insert (make-string indent ? ))
1114 (delete-horizontal-space)
1115 (insert (make-string indent ? ))
1116 1630
1117 (end-of-line) 1631 (end-of-line)
1118 (delete-horizontal-space) 1632 (delete-horizontal-space)
1119 1633
1120 ;; Set the current column, we're at the end of the title line. 1634 ;; Set the current column, we're at the end of the title line.
1121 (setq len (+ (current-column) indent)) 1635 (setq len (+ (current-column) indent))
1122 1636
1123 ;; Remove previous line if it is an adornment. 1637 ;; Remove previous line if it is an adornment.
1124 (save-excursion 1638 (save-excursion
1125 (forward-line -1) ;; testcover: FIXME: Doesn't work when in first line 1639 (forward-line -1) ;; FIXME testcover: Doesn't work when in first line of
1126 ;; of buffer. 1640 ;; buffer.
1127 (if (and (looking-at (rst-re 'ado-beg-2-1)) 1641 (if (and (looking-at (rst-re 'ado-beg-2-1))
1128 ;; Avoid removing the underline of a title right above us. 1642 ;; Avoid removing the underline of a title right above us.
1129 (save-excursion (forward-line -1) 1643 (save-excursion (forward-line -1)
1130 (not (looking-at (rst-re 'ttl-beg))))) 1644 (not (looking-at (rst-re 'ttl-beg-1)))))
1131 (rst-delete-entire-line))) 1645 (rst-delete-entire-line)))
1132 1646
1133 ;; Remove following line if it is an adornment. 1647 ;; Remove following line if it is an adornment.
1648 (save-excursion
1649 (forward-line +1) ;; FIXME testcover: Doesn't work when in last line
1650 ;; of buffer.
1651 (if (looking-at (rst-re 'ado-beg-2-1))
1652 (rst-delete-entire-line))
1653 ;; Add a newline if we're at the end of the buffer unless it is the final
1654 ;; empty line, for the subsequent inserting of the underline.
1655 (if (and (= (point) (buffer-end 1)) (not (bolp)))
1656 (newline 1)))
1657
1658 ;; Insert overline.
1659 (when (rst-Hdr-is-over-and-under hdr)
1134 (save-excursion 1660 (save-excursion
1135 (forward-line +1) ;; testcover: FIXME: Doesn't work when in last line 1661 (beginning-of-line)
1136 ;; of buffer. 1662 (open-line 1)
1137 (if (looking-at (rst-re 'ado-beg-2-1)) 1663 (insert (make-string len (rst-Hdr-get-char hdr)))))
1138 (rst-delete-entire-line)) 1664
1139 ;; Add a newline if we're at the end of the buffer, for the subsequence 1665 ;; Insert underline.
1140 ;; inserting of the underline. 1666 (1value ;; Line has been inserted above.
1141 (if (= (point) (buffer-end 1)) 1667 (forward-line +1))
1142 (newline 1))) 1668 (open-line 1)
1143 1669 (insert (make-string len (rst-Hdr-get-char hdr)))
1144 ;; Insert overline. 1670
1145 (if (eq style 'over-and-under) 1671 (1value ;; Line has been inserted above.
1146 (save-excursion 1672 (forward-line +1))
1147 (beginning-of-line) 1673 (goto-char marker)))
1148 (open-line 1)
1149 (insert (make-string len char))))
1150
1151 ;; Insert underline.
1152 (1value ;; Line has been inserted above.
1153 (forward-line +1))
1154 (open-line 1)
1155 (insert (make-string len char))
1156
1157 (1value ;; Line has been inserted above.
1158 (forward-line +1))
1159 (goto-char marker)))
1160 1674
1161(defun rst-classify-adornment (adornment end) 1675(defun rst-classify-adornment (adornment end)
1162 "Classify adornment for section titles and transitions. 1676 "Classify adornment string for section titles and transitions.
1163ADORNMENT is the complete adornment string as found in the buffer 1677ADORNMENT is the complete adornment string as found in the buffer
1164with optional trailing whitespace. END is the point after the 1678with optional trailing whitespace. END is the point after the
1165last character of ADORNMENT. 1679last character of ADORNMENT. Return a `rst-Ttl' or nil if no
1166 1680syntactically valid adornment is found."
1167Return a list. The first entry is t for a transition or a
1168cons (CHARACTER . STYLE). Check `rst-preferred-adornments' for
1169the meaning of CHARACTER and STYLE.
1170
1171The remaining list forms four match groups as returned by
1172`match-data'. Match group 0 matches the whole construct. Match
1173group 1 matches the overline adornment if present. Match group 2
1174matches the section title text or the transition. Match group 3
1175matches the underline adornment.
1176
1177Return nil if no syntactically valid adornment is found."
1178 (save-excursion 1681 (save-excursion
1179 (save-match-data 1682 (save-match-data
1180 (when (string-match (rst-re 'ado-beg-2-1) adornment) 1683 (when (string-match (rst-re 'ado-beg-2-1) adornment)
@@ -1189,31 +1692,35 @@ Return nil if no syntactically valid adornment is found."
1189 (nxt-emp ; Next line nonexistent or empty 1692 (nxt-emp ; Next line nonexistent or empty
1190 (save-excursion 1693 (save-excursion
1191 (or (not (zerop (forward-line 1))) 1694 (or (not (zerop (forward-line 1)))
1192 ;; testcover: FIXME: Add test classifying at the end of 1695 ;; FIXME testcover: Add test classifying at the end of
1193 ;; buffer. 1696 ;; buffer.
1194 (looking-at (rst-re 'lin-end))))) 1697 (looking-at (rst-re 'lin-end)))))
1195 (prv-emp ; Previous line nonexistent or empty 1698 (prv-emp ; Previous line nonexistent or empty
1196 (save-excursion 1699 (save-excursion
1197 (or (not (zerop (forward-line -1))) 1700 (or (not (zerop (forward-line -1)))
1198 (looking-at (rst-re 'lin-end))))) 1701 (looking-at (rst-re 'lin-end)))))
1702 txt-blw
1199 (ttl-blw ; Title found below starting here. 1703 (ttl-blw ; Title found below starting here.
1200 (save-excursion 1704 (save-excursion
1201 (and 1705 (and
1202 (zerop (forward-line 1)) ;; testcover: FIXME: Add test 1706 (zerop (forward-line 1)) ;; FIXME testcover: Add test
1203 ;; classifying at the end of 1707 ;; classifying at the end of
1204 ;; buffer. 1708 ;; buffer.
1205 (looking-at (rst-re 'ttl-beg)) 1709 (looking-at (rst-re 'ttl-beg-1))
1710 (setq txt-blw (match-string-no-properties 1))
1206 (point)))) 1711 (point))))
1712 txt-abv
1207 (ttl-abv ; Title found above starting here. 1713 (ttl-abv ; Title found above starting here.
1208 (save-excursion 1714 (save-excursion
1209 (and 1715 (and
1210 (zerop (forward-line -1)) 1716 (zerop (forward-line -1))
1211 (looking-at (rst-re 'ttl-beg)) 1717 (looking-at (rst-re 'ttl-beg-1))
1718 (setq txt-abv (match-string-no-properties 1))
1212 (point)))) 1719 (point))))
1213 (und-fnd ; Matching underline found starting here. 1720 (und-fnd ; Matching underline found starting here.
1214 (save-excursion 1721 (save-excursion
1215 (and ttl-blw 1722 (and ttl-blw
1216 (zerop (forward-line 2)) ;; testcover: FIXME: Add test 1723 (zerop (forward-line 2)) ;; FIXME testcover: Add test
1217 ;; classifying at the end of 1724 ;; classifying at the end of
1218 ;; buffer. 1725 ;; buffer.
1219 (looking-at (rst-re ado-re 'lin-end)) 1726 (looking-at (rst-re ado-re 'lin-end))
@@ -1224,16 +1731,16 @@ Return nil if no syntactically valid adornment is found."
1224 (zerop (forward-line -2)) 1731 (zerop (forward-line -2))
1225 (looking-at (rst-re ado-re 'lin-end)) 1732 (looking-at (rst-re ado-re 'lin-end))
1226 (point)))) 1733 (point))))
1227 key beg-ovr end-ovr beg-txt end-txt beg-und end-und) 1734 ado ind txt beg-ovr end-ovr beg-txt end-txt beg-und end-und)
1228 (cond 1735 (cond
1229 ((and nxt-emp prv-emp) 1736 ((and nxt-emp prv-emp)
1230 ;; A transition. 1737 ;; A transition.
1231 (setq key t 1738 (setq ado (rst-Ado-new-transition)
1232 beg-txt beg-pnt 1739 beg-txt beg-pnt
1233 end-txt end-pnt)) 1740 end-txt end-pnt))
1234 ((or und-fnd ovr-fnd) 1741 ((or und-fnd ovr-fnd)
1235 ;; An overline with an underline. 1742 ;; An overline with an underline.
1236 (setq key (cons ado-ch 'over-and-under)) 1743 (setq ado (rst-Ado-new-over-and-under ado-ch))
1237 (let (;; Prefer overline match over underline match. 1744 (let (;; Prefer overline match over underline match.
1238 (und-pnt (if ovr-fnd beg-pnt und-fnd)) 1745 (und-pnt (if ovr-fnd beg-pnt und-fnd))
1239 (ovr-pnt (if ovr-fnd ovr-fnd beg-pnt)) 1746 (ovr-pnt (if ovr-fnd ovr-fnd beg-pnt))
@@ -1243,41 +1750,40 @@ Return nil if no syntactically valid adornment is found."
1243 end-ovr (line-end-position)) 1750 end-ovr (line-end-position))
1244 (goto-char txt-pnt) 1751 (goto-char txt-pnt)
1245 (setq beg-txt (point) 1752 (setq beg-txt (point)
1246 end-txt (line-end-position)) 1753 end-txt (line-end-position)
1754 ind (current-indentation)
1755 txt (if ovr-fnd txt-abv txt-blw))
1247 (goto-char und-pnt) 1756 (goto-char und-pnt)
1248 (setq beg-und (point) 1757 (setq beg-und (point)
1249 end-und (line-end-position)))) 1758 end-und (line-end-position))))
1250 (ttl-abv 1759 (ttl-abv
1251 ;; An underline. 1760 ;; An underline.
1252 (setq key (cons ado-ch 'simple) 1761 (setq ado (rst-Ado-new-simple ado-ch)
1253 beg-und beg-pnt 1762 beg-und beg-pnt
1254 end-und end-pnt) 1763 end-und end-pnt)
1255 (goto-char ttl-abv) 1764 (goto-char ttl-abv)
1256 (setq beg-txt (point) 1765 (setq beg-txt (point)
1257 end-txt (line-end-position))) 1766 end-txt (line-end-position)
1767 ind (current-indentation)
1768 txt txt-abv))
1258 (t 1769 (t
1259 ;; Invalid adornment. 1770 ;; Invalid adornment.
1260 (setq key nil))) 1771 (setq ado nil)))
1261 (if key 1772 (if ado
1262 (list key 1773 (rst-Ttl-new ado
1263 (or beg-ovr beg-txt) 1774 (list
1264 (or end-und end-txt) 1775 (or beg-ovr beg-txt)
1265 beg-ovr end-ovr beg-txt end-txt beg-und end-und))))))) 1776 (or end-und end-txt)
1266 1777 beg-ovr end-ovr beg-txt end-txt beg-und end-und)
1267(defun rst-find-title-line () 1778 ind txt)))))))
1779
1780(defun rst-ttl-at-point ()
1268 "Find a section title line around point and return its characteristics. 1781 "Find a section title line around point and return its characteristics.
1269If the point is on an adornment line find the respective title 1782If the point is on an adornment line find the respective title
1270line. If the point is on an empty line check previous or next 1783line. If the point is on an empty line check previous or next
1271line whether it is a suitable title line and use it if so. If 1784line whether it is a suitable title line and use it if so. If
1272point is on a suitable title line use it. 1785point is on a suitable title line use it. Return a `rst-Ttl' for
1273 1786a section header or nil if no title line is found."
1274If no title line is found return nil.
1275
1276Otherwise return as `rst-classify-adornment' does. However, if
1277the title line has no syntactically valid adornment, STYLE is nil
1278in the first element. If there is no adornment around the title,
1279CHARACTER is also nil and match groups for overline and underline
1280are nil."
1281 (save-excursion 1787 (save-excursion
1282 (1value ;; No lines may be left to move. 1788 (1value ;; No lines may be left to move.
1283 (forward-line 0)) 1789 (forward-line 0))
@@ -1285,225 +1791,258 @@ are nil."
1285 (orig-end (line-end-position))) 1791 (orig-end (line-end-position)))
1286 (cond 1792 (cond
1287 ((looking-at (rst-re 'ado-beg-2-1)) 1793 ((looking-at (rst-re 'ado-beg-2-1))
1794 ;; Adornment found - consider it.
1288 (let ((char (string-to-char (match-string-no-properties 2))) 1795 (let ((char (string-to-char (match-string-no-properties 2)))
1289 (r (rst-classify-adornment (match-string-no-properties 0) 1796 (r (rst-classify-adornment (match-string-no-properties 0)
1290 (match-end 0)))) 1797 (match-end 0))))
1291 (cond 1798 (cond
1292 ((not r) 1799 ((not r)
1293 ;; Invalid adornment - check whether this is an incomplete overline. 1800 ;; Invalid adornment - check whether this is an overline with
1801 ;; missing underline.
1294 (if (and 1802 (if (and
1295 (zerop (forward-line 1)) 1803 (zerop (forward-line 1))
1296 (looking-at (rst-re 'ttl-beg))) 1804 (looking-at (rst-re 'ttl-beg-1)))
1297 (list (cons char nil) orig-pnt (line-end-position) 1805 (rst-Ttl-new (rst-Ado-new-over-and-under char)
1298 orig-pnt orig-end (point) (line-end-position) nil nil))) 1806 (list orig-pnt (line-end-position)
1299 ((consp (car r)) 1807 orig-pnt orig-end
1300 ;; A section title - not a transition. 1808 (point) (line-end-position)
1301 r)))) 1809 nil nil)
1810 (current-indentation)
1811 (match-string-no-properties 1))))
1812 ((rst-Ado-is-transition (rst-Ttl-ado r))
1813 nil)
1814 ;; Return any other classification as is.
1815 (r))))
1302 ((looking-at (rst-re 'lin-end)) 1816 ((looking-at (rst-re 'lin-end))
1817 ;; Empty line found - check surrounding lines for a title.
1303 (or 1818 (or
1304 (save-excursion 1819 (save-excursion
1305 (if (and (zerop (forward-line -1)) 1820 (if (and (zerop (forward-line -1))
1306 (looking-at (rst-re 'ttl-beg))) 1821 (looking-at (rst-re 'ttl-beg-1)))
1307 (list (cons nil nil) (point) (line-end-position) 1822 (rst-Ttl-new nil
1308 nil nil (point) (line-end-position) nil nil))) 1823 (list (point) (line-end-position)
1824 nil nil
1825 (point) (line-end-position)
1826 nil nil)
1827 (current-indentation)
1828 (match-string-no-properties 1))))
1309 (save-excursion 1829 (save-excursion
1310 (if (and (zerop (forward-line 1)) 1830 (if (and (zerop (forward-line 1))
1311 (looking-at (rst-re 'ttl-beg))) 1831 (looking-at (rst-re 'ttl-beg-1)))
1312 (list (cons nil nil) (point) (line-end-position) 1832 (rst-Ttl-new nil
1313 nil nil (point) (line-end-position) nil nil))))) 1833 (list (point) (line-end-position)
1314 ((looking-at (rst-re 'ttl-beg)) 1834 nil nil
1315 ;; Try to use the underline. 1835 (point) (line-end-position)
1316 (let ((r (rst-classify-adornment 1836 nil nil)
1317 (buffer-substring-no-properties 1837 (current-indentation)
1318 (line-beginning-position 2) (line-end-position 2)) 1838 (match-string-no-properties 1))))))
1319 (line-end-position 2)))) 1839 ((looking-at (rst-re 'ttl-beg-1))
1320 (if r 1840 ;; Title line found - check for a following underline.
1321 r 1841 (let ((txt (match-string-no-properties 1)))
1322 ;; No valid adornment found. 1842 (or (rst-classify-adornment
1323 (list (cons nil nil) (point) (line-end-position) 1843 (buffer-substring-no-properties
1324 nil nil (point) (line-end-position) nil nil)))))))) 1844 (line-beginning-position 2) (line-end-position 2))
1845 (line-end-position 2))
1846 ;; No valid adornment found.
1847 (rst-Ttl-new nil
1848 (list (point) (line-end-position)
1849 nil nil
1850 (point) (line-end-position)
1851 nil nil)
1852 (current-indentation)
1853 txt))))))))
1325 1854
1326;; The following function and variables are used to maintain information about 1855;; The following function and variables are used to maintain information about
1327;; current section adornment in a buffer local cache. Thus they can be used for 1856;; current section adornment in a buffer local cache. Thus they can be used for
1328;; font-locking and manipulation commands. 1857;; font-locking and manipulation commands.
1329 1858
1330(defvar rst-all-sections nil 1859(defvar rst-all-ttls-cache nil
1331 "All section adornments in the buffer as found by `rst-find-all-adornments'. 1860 "All section adornments in the buffer as found by `rst-all-ttls'.
1332Set to t when no section adornments were found.") 1861Set to t when no section adornments were found.")
1333(make-variable-buffer-local 'rst-all-sections) 1862(make-variable-buffer-local 'rst-all-ttls-cache)
1334 1863
1335;; FIXME: If this variable is set to a different value font-locking of section 1864;; FIXME: If this variable is set to a different value font-locking of section
1336;; headers is wrong. 1865;; headers is wrong.
1337(defvar rst-section-hierarchy nil 1866(defvar rst-hdr-hierarchy-cache nil
1338 "Section hierarchy in the buffer as determined by `rst-get-hierarchy'. 1867 "Section hierarchy in the buffer as determined by `rst-hdr-hierarchy'.
1339Set to t when no section adornments were found. 1868Set to t when no section adornments were found.
1340Value depends on `rst-all-sections'.") 1869Value depends on `rst-all-ttls-cache'.")
1341(make-variable-buffer-local 'rst-section-hierarchy) 1870(make-variable-buffer-local 'rst-hdr-hierarchy-cache)
1342 1871
1343(rst-testcover-add-1value 'rst-reset-section-caches) 1872(rst-testcover-add-1value 'rst-reset-section-caches)
1344(defun rst-reset-section-caches () 1873(defun rst-reset-section-caches ()
1345 "Reset all section cache variables. 1874 "Reset all section cache variables.
1346Should be called by interactive functions which deal with sections." 1875Should be called by interactive functions which deal with sections."
1347 (setq rst-all-sections nil 1876 (setq rst-all-ttls-cache nil
1348 rst-section-hierarchy nil)) 1877 rst-hdr-hierarchy-cache nil))
1349 1878
1350(defun rst-find-all-adornments () 1879(defun rst-all-ttls ()
1351 "Return all the section adornments in the current buffer. 1880 "Return all the section adornments in the current buffer.
1352Return a list of (LINE . ADORNMENT) with ascending LINE where 1881Return a list of `rst-Ttl' with ascending line number.
1353LINE is the line containing the section title. ADORNMENT consists
1354of a (CHARACTER STYLE INDENT) triple as described for
1355`rst-preferred-adornments'.
1356 1882
1357Uses and sets `rst-all-sections'." 1883Uses and sets `rst-all-ttls-cache'."
1358 (unless rst-all-sections 1884 (unless rst-all-ttls-cache
1359 (let (positions) 1885 (let (positions)
1360 ;; Iterate over all the section titles/adornments in the file. 1886 ;; Iterate over all the section titles/adornments in the file.
1361 (save-excursion 1887 (save-excursion
1362 (goto-char (point-min)) 1888 (save-match-data
1363 (while (re-search-forward (rst-re 'ado-beg-2-1) nil t) 1889 (goto-char (point-min))
1364 (let ((ado-data (rst-classify-adornment 1890 (while (re-search-forward (rst-re 'ado-beg-2-1) nil t)
1365 (match-string-no-properties 0) (point)))) 1891 (let ((ttl (rst-classify-adornment
1366 (when (and ado-data 1892 (match-string-no-properties 0) (point))))
1367 (consp (car ado-data))) ; Ignore transitions. 1893 (when (and ttl (rst-Ado-is-section (rst-Ttl-ado ttl)))
1368 (set-match-data (cdr ado-data)) 1894 (when (rst-Ttl-evaluate-hdr ttl)
1369 (goto-char (match-beginning 2)) ; Goto the title start. 1895 (push ttl positions))
1370 (push (cons (1+ (count-lines (point-min) (point))) 1896 (goto-char (rst-Ttl-get-end ttl)))))
1371 (list (caar ado-data) 1897 (setq positions (nreverse positions))
1372 (cdar ado-data) 1898 (setq rst-all-ttls-cache (or positions t))))))
1373 (current-indentation))) 1899 (if (eq rst-all-ttls-cache t)
1374 positions)
1375 (goto-char (match-end 0))))) ; Go beyond the whole thing.
1376 (setq positions (nreverse positions))
1377 (setq rst-all-sections (or positions t)))))
1378 (if (eq rst-all-sections t)
1379 nil 1900 nil
1380 rst-all-sections)) 1901 (mapcar 'rst-Ttl-copy rst-all-ttls-cache)))
1381 1902
1382(defun rst-infer-hierarchy (adornments) 1903(defun rst-infer-hdr-hierarchy (hdrs)
1383 "Build a hierarchy of adornments using the list of given ADORNMENTS. 1904 "Build a hierarchy from HDRS.
1384 1905HDRS reflects the order in which the headers appear in the
1385ADORNMENTS is a list of (CHARACTER STYLE INDENT) adornment 1906buffer. Return a `rst-Hdr' list representing the hierarchy of
1386specifications, in order that they appear in a file, and will 1907headers in the buffer. Indentation is unified."
1387infer a hierarchy of section levels by removing adornments that 1908 (let (ado2indents)
1388have already been seen in a forward traversal of the adornments, 1909 (dolist (hdr hdrs)
1389comparing just CHARACTER and STYLE. 1910 (let* ((ado (rst-Hdr-ado hdr))
1390 1911 (indent (rst-Hdr-indent hdr))
1391Similarly returns a list of (CHARACTER STYLE INDENT), where each 1912 (found (assoc ado ado2indents)))
1392list element should be unique." 1913 (if found
1393 (let (hierarchy-alist) 1914 (unless (member indent (cdr found))
1394 (dolist (x adornments) 1915 ;; Append newly found indent.
1395 (let ((char (car x)) 1916 (setcdr found (append (cdr found) (list indent))))
1396 (style (cadr x))) 1917 (push (list ado indent) ado2indents))))
1397 (unless (assoc (cons char style) hierarchy-alist) 1918 (mapcar (lambda (ado_indents)
1398 (push (cons (cons char style) x) hierarchy-alist)))) 1919 (let ((ado (car ado_indents))
1399 (mapcar 'cdr (nreverse hierarchy-alist)))) 1920 (indents (cdr ado_indents)))
1400 1921 (rst-Hdr-new
1401(defun rst-get-hierarchy (&optional ignore) 1922 ado
1402 "Return the hierarchy of section titles in the file. 1923 (if (> (length indents) 1)
1403 1924 ;; Indentations used inconsistently - use default.
1404Return a list of adornments that represents the hierarchy of 1925 rst-default-indent
1405section titles in the file. Each element consists of (CHARACTER 1926 ;; Only one indentation used - use this.
1406STYLE INDENT) as described for `rst-find-all-adornments'. If the 1927 (car indents)))))
1407line number in IGNORE is specified, a possibly adornment found on 1928 (nreverse ado2indents))))
1408that line is not taken into account when building the hierarchy. 1929
1409 1930(defun rst-hdr-hierarchy (&optional ignore-current)
1410Uses and sets `rst-section-hierarchy' unless IGNORE is given." 1931 "Return the hierarchy of section titles in the file as a `rst-Hdr' list.
1411 (if (and (not ignore) rst-section-hierarchy) 1932Each returned element may be used directly to create a section
1412 (if (eq rst-section-hierarchy t) 1933adornment on that level. If IGNORE-CURRENT a title found on the
1413 nil 1934current line is not taken into account when building the
1414 rst-section-hierarchy) 1935hierarchy unless it appears again elsewhere. This catches cases
1415 (let ((r (rst-infer-hierarchy 1936where the current title is edited and may not be final regarding
1416 (mapcar 'cdr 1937its level.
1417 (assq-delete-all 1938
1418 ignore 1939Uses and sets `rst-hdr-hierarchy-cache' unless IGNORE-CURRENT is
1419 (rst-find-all-adornments)))))) 1940given."
1420 (setq rst-section-hierarchy 1941 (let* ((all-ttls (rst-all-ttls))
1421 (if ignore 1942 (ignore-position (if ignore-current
1422 ;; Clear cache reflecting that a possible update is not 1943 (line-beginning-position)))
1423 ;; reflected. 1944 (ignore-ttl
1424 nil 1945 (if ignore-position
1425 (or r t))) 1946 (car (member-if
1426 r))) 1947 (lambda (ttl)
1427 1948 (equal ignore-position (rst-Ttl-get-title-beginning ttl)))
1428(defun rst-get-adornments-around () 1949 all-ttls))))
1429 "Return the adornments around point. 1950 (really-ignore
1430Return a list of the previous and next adornments." 1951 (if ignore-ttl
1431 (let* ((all (rst-find-all-adornments)) 1952 (<= (count-if
1432 (curline (line-number-at-pos)) 1953 (lambda (ttl)
1433 prev next 1954 (rst-Ado-equal (rst-Ttl-ado ignore-ttl) (rst-Ttl-ado ttl)))
1434 (cur all)) 1955 all-ttls)
1956 1)))
1957 (real-ttls (delq (if really-ignore ignore-ttl) all-ttls)))
1958 (mapcar ;; Protect cache.
1959 'rst-Hdr-copy
1960 (if (and (not ignore-current) rst-hdr-hierarchy-cache)
1961 (if (eq rst-hdr-hierarchy-cache t)
1962 nil
1963 rst-hdr-hierarchy-cache)
1964 (let ((r (rst-infer-hdr-hierarchy (mapcar 'rst-Ttl-hdr real-ttls))))
1965 (setq rst-hdr-hierarchy-cache
1966 (if ignore-current
1967 ;; Clear cache reflecting that a possible update is not
1968 ;; reflected.
1969 nil
1970 (or r t)))
1971 r)))))
1972
1973(defun rst-all-ttls-with-level ()
1974 "Return the section adornments with levels set according to hierarchy.
1975Return a list of `rst-Ttl' with ascending line number."
1976 (let ((hier (rst-Hdr-ado-map (rst-hdr-hierarchy))))
1977 (mapcar
1978 (lambda (ttl)
1979 (rst-Ttl-set-level ttl (rst-Ado-position (rst-Ttl-ado ttl) hier))
1980 ttl)
1981 (rst-all-ttls))))
1982
1983(defun rst-get-previous-hdr ()
1984 "Return the `rst-Hdr' before point or nil if none."
1985 (let ((ttls (rst-all-ttls))
1986 (curpos (line-beginning-position))
1987 prev)
1435 1988
1436 ;; Search for the adornments around the current line. 1989 ;; Search for the adornments around the current line.
1437 (while (and cur (< (caar cur) curline)) 1990 (while (and ttls (< (rst-Ttl-get-title-beginning (car ttls)) curpos))
1438 (setq prev cur 1991 (setq prev (car ttls)
1439 cur (cdr cur))) 1992 ttls (cdr ttls)))
1440 ;; 'cur' is the following adornment. 1993 (and prev (rst-Ttl-hdr prev))))
1441 1994
1442 (if (and cur (caar cur)) 1995(defun rst-adornment-complete-p (ado indent)
1443 (setq next (if (= curline (caar cur)) (cdr cur) cur))) 1996 "Return true if the adornment ADO around point is complete using INDENT.
1444 1997The adornment is complete if it is a completely correct
1445 (mapcar 'cdar (list prev next)))) 1998reStructuredText adornment for the title line at point. This
1446 1999includes indentation and correct length of adornment lines."
1447(defun rst-adornment-complete-p (ado)
1448 "Return true if the adornment ADO around point is complete."
1449 ;; Note: we assume that the detection of the overline as being the underline 2000 ;; Note: we assume that the detection of the overline as being the underline
1450 ;; of a preceding title has already been detected, and has been eliminated 2001 ;; of a preceding title has already been detected, and has been eliminated
1451 ;; from the adornment that is given to us. 2002 ;; from the adornment that is given to us.
1452 2003 (let ((exps (rst-re "^" (rst-Ado-char ado)
1453 ;; There is some sectioning already present, so check if the current 2004 (format "\\{%d\\}"
1454 ;; sectioning is complete and correct. 2005 (+ (save-excursion
1455 (let* ((char (car ado)) 2006 ;; Determine last column of title.
1456 (style (cadr ado)) 2007 (end-of-line)
1457 (indent (caddr ado)) 2008 (current-column))
1458 (endcol (save-excursion (end-of-line) (current-column)))) 2009 indent)) "$")))
1459 (if char 2010 (and
1460 (let ((exps (rst-re "^" char (format "\\{%d\\}" (+ endcol indent)) "$"))) 2011 (save-excursion (forward-line +1)
1461 (and 2012 (looking-at exps))
1462 (save-excursion (forward-line +1) 2013 (or (rst-Ado-is-simple ado)
1463 (beginning-of-line) 2014 (save-excursion (forward-line -1)
1464 (looking-at exps)) 2015 (looking-at exps))))))
1465 (or (not (eq style 'over-and-under)) 2016
1466 (save-excursion (forward-line -1) 2017(defun rst-next-hdr (hdr hier prev down)
1467 (beginning-of-line) 2018 ;; testcover: ok.
1468 (looking-at exps)))))))) 2019 "Return the next best `rst-Hdr' upward from HDR.
1469 2020Consider existing hierarchy HIER and preferred headers. PREV may
1470 2021be a previous `rst-Hdr' which may be taken into account. If DOWN
1471(defun rst-get-next-adornment 2022return the next best `rst-Hdr' downward instead. Return nil in
1472 (curado hier &optional suggestion reverse-direction) 2023HIER is nil."
1473 "Get the next adornment for CURADO, in given hierarchy HIER. 2024 (let* ((normalized-hier (if down
1474If suggesting, suggest for new adornment SUGGESTION. 2025 hier
1475REVERSE-DIRECTION is used to reverse the cycling order." 2026 (reverse hier)))
1476 2027 (fnd (rst-Hdr-member-ado hdr normalized-hier))
1477 (let* ( 2028 (prev-fnd (and prev (rst-Hdr-member-ado prev normalized-hier))))
1478 (char (car curado))
1479 (style (cadr curado))
1480
1481 ;; Build a new list of adornments for the rotation.
1482 (rotados
1483 (append hier
1484 ;; Suggest a new adornment.
1485 (list suggestion
1486 ;; If nothing to suggest, use first adornment.
1487 (car hier)))) )
1488 (or 2029 (or
1489 ;; Search for next adornment. 2030 ;; Next entry in existing hierarchy if it exists.
1490 (cadr 2031 (cadr fnd)
1491 (let ((cur (if reverse-direction rotados 2032 (if fnd
1492 (reverse rotados)))) 2033 ;; If current header is found try introducing a new one from preferred
1493 (while (and cur 2034 ;; hierarchy.
1494 (not (and (eq char (caar cur)) 2035 (rst-new-preferred-hdr hier prev)
1495 (eq style (cadar cur))))) 2036 ;; If not found try using previous header.
1496 (setq cur (cdr cur))) 2037 (if down
1497 cur)) 2038 (cadr prev-fnd)
1498 2039 (car prev-fnd)))
1499 ;; If not found, take the first of all adornments. 2040 ;; All failed - rotate by using first from normalized existing hierarchy.
1500 suggestion))) 2041 (car normalized-hier))))
1501
1502 2042
1503;; FIXME: A line "``/`` full" is not accepted as a section title. 2043;; FIXME: A line "``/`` full" is not accepted as a section title.
1504(defun rst-adjust (pfxarg) 2044(defun rst-adjust (pfxarg)
1505 "Auto-adjust the adornment around point. 2045 "Auto-adjust the adornment around point.
1506
1507Adjust/rotate the section adornment for the section title around 2046Adjust/rotate the section adornment for the section title around
1508point or promote/demote the adornments inside the region, 2047point or promote/demote the adornments inside the region,
1509depending on whether the region is active. This function is meant 2048depending on whether the region is active. This function is meant
@@ -1516,12 +2055,9 @@ the adornments of a section title in reStructuredText. It tries
1516to deal with all the possible cases gracefully and to do \"the 2055to deal with all the possible cases gracefully and to do \"the
1517right thing\" in all cases. 2056right thing\" in all cases.
1518 2057
1519See the documentations of `rst-adjust-adornment-work' and 2058See the documentations of `rst-adjust-section' and
1520`rst-promote-region' for full details. 2059`rst-promote-region' for full details.
1521 2060
1522Prefix Arguments
1523================
1524
1525The method can take either (but not both) of 2061The method can take either (but not both) of
1526 2062
1527a. a (non-negative) prefix argument, which means to toggle the 2063a. a (non-negative) prefix argument, which means to toggle the
@@ -1542,11 +2078,15 @@ b. a negative numerical argument, which generally inverts the
1542 ;; Adjust adornments within region. 2078 ;; Adjust adornments within region.
1543 (rst-promote-region (and pfxarg t)) 2079 (rst-promote-region (and pfxarg t))
1544 ;; Adjust adornment around point. 2080 ;; Adjust adornment around point.
1545 (rst-adjust-adornment-work toggle-style reverse-direction)) 2081 (let ((msg (rst-adjust-section toggle-style reverse-direction)))
2082 (when msg
2083 (apply 'message msg))))
1546 2084
1547 ;; Run the hooks to run after adjusting. 2085 ;; Run the hooks to run after adjusting.
1548 (run-hooks 'rst-adjust-hook) 2086 (run-hooks 'rst-adjust-hook)
1549 2087
2088 (rst-reset-section-caches)
2089
1550 ;; Make sure to reset the cursor position properly after we're done. 2090 ;; Make sure to reset the cursor position properly after we're done.
1551 (goto-char origpt))) 2091 (goto-char origpt)))
1552 2092
@@ -1567,31 +2107,23 @@ b. a negative numerical argument, which generally inverts the
1567(rst-testcover-defcustom) 2107(rst-testcover-defcustom)
1568 2108
1569(defun rst-adjust-adornment (pfxarg) 2109(defun rst-adjust-adornment (pfxarg)
1570 "Call `rst-adjust-adornment-work' interactively. 2110 "Call `rst-adjust-section' interactively.
1571
1572Keep this for compatibility for older bindings (are there any?). 2111Keep this for compatibility for older bindings (are there any?).
1573Argument PFXARG has the same meaning as for `rst-adjust'." 2112Argument PFXARG has the same meaning as for `rst-adjust'."
1574 (interactive "P") 2113 (interactive "P")
1575 2114
1576 (let* ((reverse-direction (and pfxarg (< (prefix-numeric-value pfxarg) 0))) 2115 (let* ((reverse-direction (and pfxarg (< (prefix-numeric-value pfxarg) 0)))
1577 (toggle-style (and pfxarg (not reverse-direction)))) 2116 (toggle-style (and pfxarg (not reverse-direction))))
1578 (rst-adjust-adornment-work toggle-style reverse-direction))) 2117 (rst-adjust-section toggle-style reverse-direction)))
1579 2118
1580(defun rst-adjust-adornment-work (toggle-style reverse-direction) 2119(defun rst-adjust-section (toggle-style reverse)
1581"Adjust/rotate the section adornment for the section title around point. 2120"Adjust/rotate the section adornment for the section title around point.
2121The action this function takes depends on context around the
2122point, and it is meant to be invoked possibly more than once to
2123rotate among the various possibilities. Basically, this function
2124deals with:
1582 2125
1583This function is meant to be invoked possibly multiple times, and 2126- adding an adornment if the title does not have one;
1584can vary its behavior with a true TOGGLE-STYLE argument, or with
1585a REVERSE-DIRECTION argument.
1586
1587General Behavior
1588================
1589
1590The next action it takes depends on context around the point, and
1591it is meant to be invoked possibly more than once to rotate among
1592the various possibilities. Basically, this function deals with:
1593
1594- adding a adornment if the title does not have one;
1595 2127
1596- adjusting the length of the underline characters to fit a 2128- adjusting the length of the underline characters to fit a
1597 modified title; 2129 modified title;
@@ -1599,316 +2131,242 @@ the various possibilities. Basically, this function deals with:
1599- rotating the adornment in the set of already existing 2131- rotating the adornment in the set of already existing
1600 sectioning adornments used in the file; 2132 sectioning adornments used in the file;
1601 2133
1602- switching between simple and over-and-under styles. 2134- switching between simple and over-and-under styles by giving
1603 2135 TOGGLE-STYLE.
1604You should normally not have to read all the following, just
1605invoke the method and it will do the most obvious thing that you
1606would expect.
1607
1608
1609Adornment Definitions
1610=====================
1611
1612The adornments consist in
1613
16141. a CHARACTER
1615
16162. a STYLE which can be either `simple' or `over-and-under'.
1617
16183. an INDENT (meaningful for the over-and-under style only)
1619 which determines how many characters and over-and-under
1620 style is hanging outside of the title at the beginning and
1621 ending.
1622
1623See source code for mode details.
1624
1625
1626Detailed Behavior Description
1627=============================
1628
1629Here are the gory details of the algorithm (it seems quite
1630complicated, but really, it does the most obvious thing in all
1631the particular cases):
1632
1633Before applying the adornment change, the cursor is placed on
1634the closest line that could contain a section title.
1635
1636Case 1: No Adornment
1637--------------------
1638
1639If the current line has no adornment around it,
1640
1641- search backwards for the last previous adornment, and apply
1642 the adornment one level lower to the current line. If there
1643 is no defined level below this previous adornment, we suggest
1644 the most appropriate of the `rst-preferred-adornments'.
1645
1646 If REVERSE-DIRECTION is true, we simply use the previous
1647 adornment found directly.
1648
1649- if there is no adornment found in the given direction, we use
1650 the first of `rst-preferred-adornments'.
1651 2136
1652TOGGLE-STYLE forces a toggle of the prescribed adornment style. 2137Return nil if the function did something. If the function were
2138not able to do something return an argument list for `message' to
2139inform the user about what failed.
1653 2140
1654Case 2: Incomplete Adornment 2141The following is a detailed description but you should normally
1655---------------------------- 2142not have to read it.
1656 2143
1657If the current line does have an existing adornment, but the 2144Before applying the adornment change, the cursor is placed on the
1658adornment is incomplete, that is, the underline/overline does 2145closest line that could contain a section title if such is found
1659not extend to exactly the end of the title line (it is either 2146around the cursor. Then the following cases are distinguished.
1660too short or too long), we simply extend the length of the
1661underlines/overlines to fit exactly the section title.
1662 2147
1663If TOGGLE-STYLE we toggle the style of the adornment as well. 2148* Case 1: No Adornment
1664 2149
1665REVERSE-DIRECTION has no effect in this case. 2150 If the current line has no adornment around it,
1666 2151
1667Case 3: Complete Existing Adornment 2152 - search for a previous adornment, and apply this adornment (unless
1668----------------------------------- 2153 `rst-new-adornment-down') or one level lower (otherwise) to the current
2154 line. If there is no defined level below this previous adornment, we
2155 suggest the most appropriate of the `rst-preferred-adornments'.
1669 2156
1670If the adornment is complete (i.e. the underline (overline) 2157 If REVERSE is true, we simply use the previous adornment found
1671length is already adjusted to the end of the title line), we 2158 directly.
1672search/parse the file to establish the hierarchy of all the
1673adornments (making sure not to include the adornment around
1674point), and we rotate the current title's adornment from within
1675that list (by default, going *down* the hierarchy that is present
1676in the file, i.e. to a lower section level). This is meant to be
1677used potentially multiple times, until the desired adornment is
1678found around the title.
1679 2159
1680If we hit the boundary of the hierarchy, exactly one choice from 2160 - if there is no adornment found in the given direction, we use the first of
1681the list of preferred adornments is suggested/chosen, the first 2161 `rst-preferred-adornments'.
1682of those adornment that has not been seen in the file yet (and
1683not including the adornment around point), and the next
1684invocation rolls over to the other end of the hierarchy (i.e. it
1685cycles). This allows you to avoid having to set which character
1686to use.
1687 2162
1688If REVERSE-DIRECTION is true, the effect is to change the 2163 TOGGLE-STYLE forces a toggle of the prescribed adornment style.
1689direction of rotation in the hierarchy of adornments, thus
1690instead going *up* the hierarchy.
1691 2164
1692However, if TOGGLE-STYLE, we do not rotate the adornment, but 2165* Case 2: Incomplete Adornment
1693instead simply toggle the style of the current adornment (this
1694should be the most common way to toggle the style of an existing
1695complete adornment).
1696 2166
2167 If the current line does have an existing adornment, but the adornment is
2168 incomplete, that is, the underline/overline does not extend to exactly the
2169 end of the title line (it is either too short or too long), we simply extend
2170 the length of the underlines/overlines to fit exactly the section title.
1697 2171
1698Point Location 2172 If TOGGLE-STYLE we toggle the style of the adornment as well.
1699==============
1700 2173
1701The invocation of this function can be carried out anywhere 2174 REVERSE has no effect in this case.
1702within the section title line, on an existing underline or
1703overline, as well as on an empty line following a section title.
1704This is meant to be as convenient as possible.
1705 2175
2176* Case 3: Complete Existing Adornment
1706 2177
1707Indented Sections 2178 If the adornment is complete (i.e. the underline (overline) length is already
1708================= 2179 adjusted to the end of the title line), we rotate the current title's
2180 adornment according to the adornment hierarchy found in the buffer. This is
2181 meant to be used potentially multiple times, until the desired adornment is
2182 found around the title.
1709 2183
1710Indented section titles such as :: 2184 If we hit the boundary of the hierarchy, exactly one choice from the list of
2185 preferred adornments is suggested/chosen, the first of those adornment that
2186 has not been seen in the buffer yet, and the next invocation rolls over to
2187 the other end of the hierarchy (i.e. it cycles).
1711 2188
1712 My Title 2189 If REVERSE is we go up in the hierarchy. Otherwise we go down.
1713 --------
1714 2190
1715are invalid in reStructuredText and thus not recognized by the 2191 However, if TOGGLE-STYLE, we do not rotate the adornment, but instead simply
1716parser. This code will thus not work in a way that would support 2192 toggle the style of the current adornment."
1717indented sections (it would be ambiguous anyway).
1718
1719
1720Joint Sections
1721==============
1722
1723Section titles that are right next to each other may not be
1724treated well. More work might be needed to support those, and
1725special conditions on the completeness of existing adornments
1726might be required to make it non-ambiguous.
1727
1728For now we assume that the adornments are disjoint, that is,
1729there is at least a single line between the titles/adornment
1730lines."
1731 (rst-reset-section-caches) 2193 (rst-reset-section-caches)
1732 (let ((ttl-fnd (rst-find-title-line)) 2194 (let ((ttl (rst-ttl-at-point))
1733 (orig-pnt (point))) 2195 (orig-pnt (point))
1734 (when ttl-fnd 2196 msg)
1735 (set-match-data (cdr ttl-fnd)) 2197 (if (not ttl)
1736 (goto-char (match-beginning 2)) 2198 (setq msg '("No section header or candidate at point"))
1737 (let* ((moved (- (line-number-at-pos) (line-number-at-pos orig-pnt))) 2199 (goto-char (rst-Ttl-get-title-beginning ttl))
1738 (char (caar ttl-fnd)) 2200 (let ((moved (- (line-number-at-pos) (line-number-at-pos orig-pnt)))
1739 (style (cdar ttl-fnd)) 2201 (found (rst-Ttl-ado ttl))
1740 (indent (current-indentation)) 2202 (indent (rst-Ttl-indent ttl))
1741 (curado (list char style indent)) 2203 (prev (rst-get-previous-hdr))
1742 char-new style-new indent-new) 2204 new)
1743 (cond 2205 (when (and found (not (rst-Ado-p found)))
1744 ;;------------------------------------------------------------------- 2206 ;; Normalize found adornment - overline with no underline counts as
1745 ;; Case 1: No valid adornment 2207 ;; overline.
1746 ((not style) 2208 (setq found (rst-Ado-new-over-and-under found)))
1747 (let ((prev (car (rst-get-adornments-around))) 2209 (setq new
1748 cur 2210 (cond
1749 (hier (rst-get-hierarchy))) 2211 ((not found)
1750 ;; Advance one level down. 2212 ;; Case 1: No adornment at all.
1751 (setq cur 2213 (let ((hier (rst-hdr-hierarchy)))
1752 (if prev 2214 (if prev
1753 (if (or (and rst-new-adornment-down reverse-direction) 2215 ;; Previous header exists - use it.
1754 (and (not rst-new-adornment-down) 2216 (cond
1755 (not reverse-direction))) 2217 ;; Customization and parameters require that the
1756 prev 2218 ;; previous level is used - use it as is.
1757 (or (cadr (rst-get-adornment-match hier prev)) 2219 ((or (and rst-new-adornment-down reverse)
1758 (rst-suggest-new-adornment hier prev))) 2220 (and (not rst-new-adornment-down) (not reverse)))
1759 (copy-sequence (car rst-preferred-adornments)))) 2221 prev)
1760 ;; Invert the style if requested. 2222 ;; Advance one level down.
1761 (if toggle-style 2223 ((rst-next-hdr prev hier prev t))
1762 (setcar (cdr cur) (if (eq (cadr cur) 'simple) 2224 (t
1763 'over-and-under 'simple)) ) 2225 (setq msg '("Neither hierarchy nor preferences can suggest a deeper header"))
1764 (setq char-new (car cur) 2226 nil))
1765 style-new (cadr cur) 2227 ;; First header in the buffer - use the first adornment
1766 indent-new (caddr cur)))) 2228 ;; from preferences or hierarchy.
1767 ;;------------------------------------------------------------------- 2229 (let ((p (car (rst-Hdr-preferred-adornments)))
1768 ;; Case 2: Incomplete Adornment 2230 (h (car hier)))
1769 ((not (rst-adornment-complete-p curado)) 2231 (cond
1770 ;; Invert the style if requested. 2232 ((if reverse
1771 (if toggle-style 2233 ;; Prefer hierarchy for downwards
1772 (setq style (if (eq style 'simple) 'over-and-under 'simple))) 2234 (or h p)
1773 (setq char-new char 2235 ;; Prefer preferences for upwards
1774 style-new style 2236 (or p h)))
1775 indent-new indent)) 2237 (t
1776 ;;------------------------------------------------------------------- 2238 (setq msg '("No preferences to suggest a top level from"))
1777 ;; Case 3: Complete Existing Adornment 2239 nil))))))
1778 (t 2240 ((not (rst-adornment-complete-p found indent))
1779 (if toggle-style 2241 ;; Case 2: Incomplete adornment.
1780 ;; Simply switch the style of the current adornment. 2242 ;; Use lax since indentation might not match suggestion.
1781 (setq char-new char 2243 (rst-Hdr-new-lax found indent))
1782 style-new (if (eq style 'simple) 'over-and-under 'simple) 2244 ;; Case 3: Complete adornment exists from here on.
1783 indent-new rst-default-indent) 2245 (toggle-style
1784 ;; Else, we rotate, ignoring the adornment around the current 2246 ;; Simply switch the style of the current adornment.
1785 ;; line... 2247 (setq toggle-style nil) ;; Remember toggling has been done.
1786 (let* ((hier (rst-get-hierarchy (line-number-at-pos))) 2248 (rst-Hdr-new-invert found rst-default-indent))
1787 ;; Suggestion, in case we need to come up with something new. 2249 (t
1788 (suggestion (rst-suggest-new-adornment 2250 ;; Rotate, ignoring a sole adornment around the current line.
1789 hier 2251 (let ((hier (rst-hdr-hierarchy t)))
1790 (car (rst-get-adornments-around)))) 2252 (cond
1791 (nextado (rst-get-next-adornment 2253 ;; Next header can be determined from hierarchy or
1792 curado hier suggestion reverse-direction))) 2254 ;; preferences.
1793 ;; Indent, if present, always overrides the prescribed indent. 2255 ((rst-next-hdr
1794 (setq char-new (car nextado) 2256 ;; Use lax since indentation might not match suggestion.
1795 style-new (cadr nextado) 2257 (rst-Hdr-new-lax found indent) hier prev reverse))
1796 indent-new (caddr nextado)))))) 2258 ;; No next header found.
1797 ;; Override indent with present indent! 2259 (t
1798 (setq indent-new (if (> indent 0) indent indent-new)) 2260 (setq msg '("No preferences or hierarchy to suggest another level from"))
1799 (if (and char-new style-new) 2261 nil))))))
1800 (rst-update-section char-new style-new indent-new)) 2262 (if (not new)
1801 ;; Correct the position of the cursor to more accurately reflect where 2263 (goto-char orig-pnt)
1802 ;; it was located when the function was invoked. 2264 (when toggle-style
1803 (unless (zerop moved) 2265 (setq new (rst-Hdr-new-invert (rst-Hdr-ado new) indent)))
1804 (forward-line (- moved)) 2266 ;; Override indent with present indent if there is some.
1805 (end-of-line)))))) 2267 (when (> indent 0)
2268 ;; Use lax since existing indent may not be valid for new style.
2269 (setq new (rst-Hdr-new-lax (rst-Hdr-ado new) indent)))
2270 (rst-update-section new)
2271 ;; Correct the position of the cursor to more accurately reflect where
2272 ;; it was located when the function was invoked.
2273 (unless (zerop moved)
2274 (forward-line (- moved))
2275 (end-of-line)))))
2276 msg))
1806 2277
1807;; Maintain an alias for compatibility. 2278;; Maintain an alias for compatibility.
1808(defalias 'rst-adjust-section-title 'rst-adjust) 2279(defalias 'rst-adjust-section-title 'rst-adjust)
1809 2280
1810
1811(defun rst-promote-region (demote) 2281(defun rst-promote-region (demote)
1812 "Promote the section titles within the region. 2282 "Promote the section titles within the region.
1813
1814With argument DEMOTE or a prefix argument, demote the section 2283With argument DEMOTE or a prefix argument, demote the section
1815titles instead. The algorithm used at the boundaries of the 2284titles instead. The algorithm used at the boundaries of the
1816hierarchy is similar to that used by `rst-adjust-adornment-work'." 2285hierarchy is similar to that used by `rst-adjust-section'."
1817 (interactive "P") 2286 (interactive "P")
1818 (rst-reset-section-caches) 2287 (rst-reset-section-caches)
1819 (let* ((cur (rst-find-all-adornments)) 2288 (let ((ttls (rst-all-ttls))
1820 (hier (rst-get-hierarchy)) 2289 (hier (rst-hdr-hierarchy))
1821 (suggestion (rst-suggest-new-adornment hier)) 2290 (region-beg (save-excursion
1822 2291 (goto-char (region-beginning))
1823 (region-begin-line (line-number-at-pos (region-beginning))) 2292 (line-beginning-position)))
1824 (region-end-line (line-number-at-pos (region-end))) 2293 (region-end (save-excursion
1825 2294 (goto-char (region-end))
1826 marker-list) 2295 (line-beginning-position)))
2296 marker-list)
1827 2297
1828 ;; Skip the markers that come before the region beginning. 2298 ;; Skip the markers that come before the region beginning.
1829 (while (and cur (< (caar cur) region-begin-line)) 2299 (while (and ttls (< (rst-Ttl-get-title-beginning (car ttls)) region-beg))
1830 (setq cur (cdr cur))) 2300 (setq ttls (cdr ttls)))
1831 2301
1832 ;; Create a list of markers for all the adornments which are found within 2302 ;; Create a list of markers for all the adornments which are found within
1833 ;; the region. 2303 ;; the region.
1834 (save-excursion 2304 (save-excursion
1835 (let (line) 2305 (while (and ttls (< (rst-Ttl-get-title-beginning (car ttls)) region-end))
1836 (while (and cur (< (setq line (caar cur)) region-end-line)) 2306 (push (cons (copy-marker (rst-Ttl-get-title-beginning (car ttls)))
1837 (goto-char (point-min)) 2307 (rst-Ttl-hdr (car ttls))) marker-list)
1838 (forward-line (1- line)) 2308 (setq ttls (cdr ttls)))
1839 (push (list (point-marker) (cdar cur)) marker-list)
1840 (setq cur (cdr cur)) ))
1841 2309
1842 ;; Apply modifications. 2310 ;; Apply modifications.
1843 (dolist (p marker-list) 2311 (dolist (p marker-list)
1844 ;; Go to the adornment to promote. 2312 ;; Go to the adornment to promote.
1845 (goto-char (car p)) 2313 (goto-char (car p))
1846 2314 ;; `rst-next-hdr' cannot return nil because we apply to a section
1847 ;; Update the adornment. 2315 ;; header so there is some hierarchy.
1848 (apply 'rst-update-section 2316 (rst-update-section (rst-next-hdr (cdr p) hier nil demote))
1849 ;; Rotate the next adornment.
1850 (rst-get-next-adornment
1851 (cadr p) hier suggestion demote))
1852 2317
1853 ;; Clear marker to avoid slowing down the editing after we're done. 2318 ;; Clear marker to avoid slowing down the editing after we're done.
1854 (set-marker (car p) nil)) 2319 (set-marker (car p) nil))
1855 (setq deactivate-mark nil)))) 2320 (setq deactivate-mark nil))))
1856 2321
1857 2322(defun rst-display-hdr-hierarchy ()
1858
1859(defun rst-display-adornments-hierarchy (&optional adornments)
1860 "Display the current file's section title adornments hierarchy. 2323 "Display the current file's section title adornments hierarchy.
1861This function expects a list of (CHARACTER STYLE INDENT) triples 2324Hierarchy is displayed in a temporary buffer."
1862in ADORNMENTS."
1863 (interactive) 2325 (interactive)
1864 (rst-reset-section-caches) 2326 (rst-reset-section-caches)
1865 (if (not adornments) 2327 (let ((hdrs (rst-hdr-hierarchy))
1866 (setq adornments (rst-get-hierarchy))) 2328 (level 1))
1867 (with-output-to-temp-buffer "*rest section hierarchy*" 2329 (with-output-to-temp-buffer "*rest section hierarchy*"
1868 (let ((level 1))
1869 (with-current-buffer standard-output 2330 (with-current-buffer standard-output
1870 (dolist (x adornments) 2331 (dolist (hdr hdrs)
1871 (insert (format "\nSection Level %d" level)) 2332 (insert (format "\nSection Level %d" level))
1872 (apply 'rst-update-section x) 2333 (rst-update-section hdr)
1873 (goto-char (point-max)) 2334 (goto-char (point-max))
1874 (insert "\n") 2335 (insert "\n")
1875 (incf level)))))) 2336 (incf level))))))
1876 2337
1877(defun rst-straighten-adornments () 2338;; Maintain an alias for backward compatibility.
1878 "Redo all the adornments in the current buffer. 2339(defalias 'rst-display-adornments-hierarchy 'rst-display-hdr-hierarchy)
1879This is done using our preferred set of adornments. This can be 2340
2341;; FIXME: Should accept an argument giving the hierarchy level to start with
2342;; instead of the top of the hierarchy.
2343(defun rst-straighten-sections ()
2344 "Redo the adornments of all section titles in the current buffer.
2345This is done using the preferred set of adornments. This can be
1880used, for example, when using somebody else's copy of a document, 2346used, for example, when using somebody else's copy of a document,
1881in order to adapt it to our preferred style." 2347in order to adapt it to our preferred style."
1882 (interactive) 2348 (interactive)
1883 (rst-reset-section-caches) 2349 (rst-reset-section-caches)
1884 (save-excursion 2350 (save-excursion
1885 (let (;; Get a list of pairs of (level . marker). 2351 (dolist (ttl-marker (mapcar
1886 (levels-and-markers (mapcar 2352 (lambda (ttl)
1887 (lambda (ado) 2353 (cons ttl (copy-marker
1888 (cons (rst-position (cdr ado) 2354 (rst-Ttl-get-title-beginning ttl))))
1889 (rst-get-hierarchy)) 2355 (rst-all-ttls-with-level)))
1890 (progn 2356 ;; Go to the appropriate position.
1891 (goto-char (point-min)) 2357 (goto-char (cdr ttl-marker))
1892 (forward-line (1- (car ado))) 2358 (rst-update-section (nth (rst-Ttl-level (car ttl-marker))
1893 (point-marker)))) 2359 (rst-Hdr-preferred-adornments)))
1894 (rst-find-all-adornments)))) 2360 ;; Reset the marker to avoid slowing down editing.
1895 (dolist (lm levels-and-markers) 2361 (set-marker (cdr ttl-marker) nil))))
1896 ;; Go to the appropriate position. 2362
1897 (goto-char (cdr lm)) 2363;; Maintain an alias for compatibility.
1898 2364(defalias 'rst-straighten-adornments 'rst-straighten-sections)
1899 ;; Apply the new style.
1900 (apply 'rst-update-section (nth (car lm) rst-preferred-adornments))
1901
1902 ;; Reset the marker to avoid slowing down editing until it gets GC'ed.
1903 (set-marker (cdr lm) nil)))))
1904 2365
1905 2366
1906;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2367;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1907;; Insert list items 2368;; Insert list items
1908;; =================
1909
1910 2369
1911;=================================================
1912; Borrowed from a2r.el (version 1.3), by Lawrence Mitchell <wence@gmx.li>. 2370; Borrowed from a2r.el (version 1.3), by Lawrence Mitchell <wence@gmx.li>.
1913; I needed to make some tiny changes to the functions, so I put it here. 2371; I needed to make some tiny changes to the functions, so I put it here.
1914; -- Wei-Wei Guo 2372; -- Wei-Wei Guo
@@ -1956,7 +2414,8 @@ If optional ARG is non-nil, insert in current buffer."
1956 string (replace-match "" nil t string)) 2414 string (replace-match "" nil t string))
1957 (setq map (cdr map)))) 2415 (setq map (cdr map))))
1958 (if arg (insert res) res))) 2416 (if arg (insert res) res)))
1959;================================================= 2417
2418;; End of borrow.
1960 2419
1961(defun rst-find-pfx-in-region (beg end pfx-re) 2420(defun rst-find-pfx-in-region (beg end pfx-re)
1962 "Find all the positions of prefixes in region between BEG and END. 2421 "Find all the positions of prefixes in region between BEG and END.
@@ -2124,7 +2583,9 @@ If PREFER-ROMAN roman numbering is preferred over using letters."
2124 (1+ (string-to-char (match-string 0 curitem)))) 2583 (1+ (string-to-char (match-string 0 curitem))))
2125 nil nil curitem))))) 2584 nil nil curitem)))))
2126 2585
2127 2586;; FIXME: At least the contiunation may be fold into
2587;; `newline-and-indent`. However, this may not be wanted by everyone so
2588;; it should be possible to switch this off.
2128(defun rst-insert-list (&optional prefer-roman) 2589(defun rst-insert-list (&optional prefer-roman)
2129 "Insert a list item at the current point. 2590 "Insert a list item at the current point.
2130 2591
@@ -2197,112 +2658,57 @@ adjust. If bullets are found on levels beyond the
2197 2658
2198;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2659;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2199;; Table of contents 2660;; Table of contents
2200;; ================= 2661
2201 2662(defun rst-all-stn ()
2202;; FIXME: Return value should be a `defstruct'. 2663 "Return the hierarchical tree of section titles as a top level `rst-Stn'.
2203(defun rst-section-tree () 2664Return nil for no section titles."
2204 "Return the hierarchical tree of section titles. 2665 ;; FIXME: The top level node may contain the document title instead of nil.
2205A tree entry looks like ((TITLE MARKER) CHILD...). TITLE is the 2666 (cdr (rst-remaining-stn (rst-all-ttls-with-level) -1)))
2206stripped text of the section title. MARKER is a marker for the 2667
2207beginning of the title text. For the top node or a missing 2668(defun rst-remaining-stn (remaining lev)
2208section level node TITLE is nil and MARKER points to the title
2209text of the first child. Each CHILD is another tree entry. The
2210CHILD list may be empty."
2211 (let ((hier (rst-get-hierarchy))
2212 (ch-sty2level (make-hash-table :test 'equal :size 10))
2213 lev-ttl-mrk-l)
2214
2215 (let ((lev 0))
2216 (dolist (ado hier)
2217 ;; Compare just the character and indent in the hash table.
2218 (puthash (cons (car ado) (cadr ado)) lev ch-sty2level)
2219 (incf lev)))
2220
2221 ;; Create a list that contains (LEVEL TITLE MARKER) for each adornment.
2222 (save-excursion
2223 (setq lev-ttl-mrk-l
2224 (mapcar (lambda (ado)
2225 (goto-char (point-min))
2226 (1value ;; This should really succeed.
2227 (forward-line (1- (car ado))))
2228 (list (gethash (cons (cadr ado) (caddr ado)) ch-sty2level)
2229 ;; Get title.
2230 (save-excursion
2231 (if (re-search-forward
2232 (rst-re "\\S .*\\S ") (line-end-position) t)
2233 (buffer-substring-no-properties
2234 (match-beginning 0) (match-end 0))
2235 ""))
2236 (point-marker)))
2237 (rst-find-all-adornments))))
2238 (cdr (rst-section-tree-rec lev-ttl-mrk-l -1))))
2239
2240;; FIXME: Return value should be a `defstruct'.
2241(defun rst-section-tree-rec (remaining lev)
2242 "Process the first entry of REMAINING expected to be on level LEV. 2669 "Process the first entry of REMAINING expected to be on level LEV.
2243REMAINING is the remaining list of adornments consisting 2670REMAINING is the remaining list of `rst-Ttl' entries.
2244of (LEVEL TITLE MARKER) entries. 2671Return (UNPROCESSED . NODE) for the first entry of REMAINING.
2245 2672UNPROCESSED is the list of still unprocessed entries. NODE is a
2246Return (UNPROCESSED (TITLE MARKER) CHILD...) for the first entry 2673`rst-Stn' or nil if REMAINING is empty."
2247of REMAINING where TITLE is nil if the expected level is not 2674 (let ((ttl (car remaining))
2248matched. UNPROCESSED is the list of still unprocessed entries.
2249Each CHILD is a child of this entry in the same format but
2250without UNPROCESSED."
2251 (let ((cur (car remaining))
2252 (unprocessed remaining) 2675 (unprocessed remaining)
2253 ttl-mrk children) 2676 fnd children)
2254 ;; If the current adornment matches expected level. 2677 ;; If the current adornment matches expected level.
2255 (when (and cur (= (car cur) lev)) 2678 (when (and ttl (= (rst-Ttl-level ttl) lev))
2256 ;; Consume the current entry and create the current node with it. 2679 ;; Consume the current entry and create the current node with it.
2257 (setq unprocessed (cdr remaining)) 2680 (setq unprocessed (cdr remaining))
2258 (setq ttl-mrk (cdr cur))) 2681 (setq fnd ttl))
2259
2260 ;; Build the child nodes as long as they have deeper level. 2682 ;; Build the child nodes as long as they have deeper level.
2261 (while (and unprocessed (> (caar unprocessed) lev)) 2683 (while (and unprocessed (> (rst-Ttl-level (car unprocessed)) lev))
2262 (let ((rem-children (rst-section-tree-rec unprocessed (1+ lev)))) 2684 (let* ((rem-child (rst-remaining-stn unprocessed (1+ lev)))
2263 (setq children (cons (cdr rem-children) children)) 2685 (child (cdr rem-child)))
2264 (setq unprocessed (car rem-children)))) 2686 (when child
2687 (push child children))
2688 (setq unprocessed (car rem-child))))
2265 (setq children (reverse children)) 2689 (setq children (reverse children))
2266
2267 (cons unprocessed 2690 (cons unprocessed
2268 (cons (or ttl-mrk 2691 (if (or fnd children)
2269 ;; Node on this level missing - use nil as text and the 2692 (rst-Stn-new fnd lev children)))))
2270 ;; marker of the first child. 2693
2271 (cons nil (cdaar children))) 2694(defun rst-stn-containing-point (stn &optional point)
2272 children)))) 2695 "Return `rst-Stn' in STN before POINT or nil if in no section.
2273 2696POINT defaults to the current point. STN may be nil for no
2274(defun rst-section-tree-point (tree &optional point) 2697section headers at all."
2275 "Return section containing POINT by returning the closest node in TREE. 2698 (when stn
2276TREE is a section tree as returned by `rst-section-tree' 2699 (setq point (or point (point)))
2277consisting of (NODE CHILD...) entries. POINT defaults to the 2700 (when (>= point (rst-Stn-get-title-beginning stn))
2278current point. A NODE must have the structure (IGNORED MARKER...). 2701 ;; Point may be in this section or a child.
2279 2702 (let ((children (rst-Stn-children stn))
2280Return (PATH NODE CHILD...). NODE is the node where POINT is in 2703 found)
2281if any. PATH is a list of nodes from the top of the tree down to 2704 (while (and children
2282and including NODE. List of CHILD are the children of NODE if any." 2705 (>= point (rst-Stn-get-title-beginning (car children))))
2283 (setq point (or point (point))) 2706 ;; Point may be in this child.
2284 (let ((cur (car tree)) 2707 (setq found (car children)
2285 (children (cdr tree))) 2708 children (cdr children)))
2286 ;; Point behind current node? 2709 (if found
2287 (if (and (cadr cur) (>= point (cadr cur))) 2710 (rst-stn-containing-point found point)
2288 ;; Iterate all the children, looking for one that might contain the 2711 stn)))))
2289 ;; current section.
2290 (let (found)
2291 (while (and children (>= point (cadaar children)))
2292 (setq found children
2293 children (cdr children)))
2294 (if found
2295 ;; Found section containing point in children.
2296 (let ((sub (rst-section-tree-point (car found) point)))
2297 ;; Extend path with current node and return NODE CHILD... from
2298 ;; sub.
2299 (cons (cons cur (car sub)) (cdr sub)))
2300 ;; Point in this section: Start a new path with current node and
2301 ;; return current NODE CHILD...
2302 (cons (list cur) tree)))
2303 ;; Current node behind point: start a new path with current node and
2304 ;; no NODE CHILD...
2305 (list (list cur)))))
2306 2712
2307(defgroup rst-toc nil 2713(defgroup rst-toc nil
2308 "Settings for reStructuredText table of contents." 2714 "Settings for reStructuredText table of contents."
@@ -2337,6 +2743,7 @@ indentation style:
2337 :group 'rst-toc) 2743 :group 'rst-toc)
2338(rst-testcover-defcustom) 2744(rst-testcover-defcustom)
2339 2745
2746;; FIXME: What does this mean?
2340;; This is used to avoid having to change the user's mode. 2747;; This is used to avoid having to change the user's mode.
2341(defvar rst-toc-insert-click-keymap 2748(defvar rst-toc-insert-click-keymap
2342 (let ((map (make-sparse-keymap))) 2749 (let ((map (make-sparse-keymap)))
@@ -2351,7 +2758,7 @@ indentation style:
2351(rst-testcover-defcustom) 2758(rst-testcover-defcustom)
2352 2759
2353(defun rst-toc-insert (&optional pfxarg) 2760(defun rst-toc-insert (&optional pfxarg)
2354 "Insert a simple text rendering of the table of contents. 2761 "Insert a text rendering of the table of contents of the current section.
2355By default the top level is ignored if there is only one, because 2762By default the top level is ignored if there is only one, because
2356we assume that the document will have a single title. 2763we assume that the document will have a single title.
2357 2764
@@ -2361,98 +2768,77 @@ to the specified level.
2361The TOC is inserted indented at the current column." 2768The TOC is inserted indented at the current column."
2362 (interactive "P") 2769 (interactive "P")
2363 (rst-reset-section-caches) 2770 (rst-reset-section-caches)
2364 (let* (;; Check maximum level override. 2771 (let (;; Check maximum level override.
2365 (rst-toc-insert-max-level 2772 (rst-toc-insert-max-level
2366 (if (and (integerp pfxarg) (> (prefix-numeric-value pfxarg) 0)) 2773 (if (and (integerp pfxarg) (> (prefix-numeric-value pfxarg) 0))
2367 (prefix-numeric-value pfxarg) rst-toc-insert-max-level)) 2774 (prefix-numeric-value pfxarg) rst-toc-insert-max-level))
2368 2775 (pt-stn (rst-stn-containing-point (rst-all-stn)))
2369 ;; Get the section tree for the current cursor point. 2776 ;; Figure out initial indent.
2370 (sectree-pair 2777 (initial-indent (make-string (current-column) ? ))
2371 (rst-section-tree-point 2778 (init-point (point)))
2372 (rst-section-tree))) 2779 (when (and pt-stn (rst-Stn-children pt-stn))
2373 2780 (rst-toc-insert-node pt-stn 0 initial-indent "")
2374 ;; Figure out initial indent. 2781 ;; FIXME: Really having the last newline would be better.
2375 (initial-indent (make-string (current-column) ? ))
2376 (init-point (point)))
2377
2378 (when (cddr sectree-pair)
2379 (rst-toc-insert-node (cdr sectree-pair) 0 initial-indent "")
2380
2381 ;; Fixup for the first line.
2382 (delete-region init-point (+ init-point (length initial-indent)))
2383
2384 ;; Delete the last newline added. 2782 ;; Delete the last newline added.
2385 (delete-char -1)))) 2783 (delete-char -1))))
2386 2784
2387(defun rst-toc-insert-node (node level indent pfx) 2785(defun rst-toc-insert-node (stn level indent pfx)
2388 "Insert tree node NODE in table-of-contents. 2786 "Insert STN in table-of-contents.
2389Recursive function that does printing of the inserted TOC. 2787LEVEL is the depth level of the sections in the tree currently
2390LEVEL is the depth level of the sections in the tree. 2788rendered. INDENT is the indentation string. PFX is the prefix
2391INDENT is the indentation string. PFX is the prefix numbering, 2789numbering, that includes the alignment necessary for all the
2392that includes the alignment necessary for all the children of 2790children of level to align."
2393level to align."
2394
2395 ;; Note: we do child numbering from the parent, so we start number the 2791 ;; Note: we do child numbering from the parent, so we start number the
2396 ;; children one level before we print them. 2792 ;; children one level before we print them.
2397 (let ((do-print (> level 0)) 2793 (when (> level 0)
2398 (count 1)) 2794 (unless (> (current-column) 0)
2399 (when do-print 2795 ;; No indent yet - insert it.
2400 (insert indent) 2796 (insert indent))
2401 (let ((b (point))) 2797 (let ((beg (point)))
2402 (unless (equal rst-toc-insert-style 'plain) 2798 (unless (equal rst-toc-insert-style 'plain)
2403 (insert pfx rst-toc-insert-number-separator)) 2799 (insert pfx rst-toc-insert-number-separator))
2404 (insert (or (caar node) "[missing node]")) 2800 (insert (rst-Stn-get-text stn))
2405 ;; Add properties to the text, even though in normal text mode it 2801 ;; Add properties to the text, even though in normal text mode it
2406 ;; won't be doing anything for now. Not sure that I want to change 2802 ;; won't be doing anything for now. Not sure that I want to change
2407 ;; mode stuff. At least the highlighting gives the idea that this 2803 ;; mode stuff. At least the highlighting gives the idea that this
2408 ;; is generated automatically. 2804 ;; is generated automatically.
2409 (put-text-property b (point) 'mouse-face 'highlight) 2805 (put-text-property beg (point) 'mouse-face 'highlight)
2410 (put-text-property b (point) 'rst-toc-target (cadar node)) 2806 (put-text-property
2411 (put-text-property b (point) 'keymap rst-toc-insert-click-keymap)) 2807 beg (point) 'rst-toc-target
2412 (insert "\n") 2808 (set-marker (make-marker) (rst-Stn-get-title-beginning stn)))
2413 2809 (put-text-property beg (point) 'keymap rst-toc-insert-click-keymap))
2414 ;; Prepare indent for children. 2810 (insert "\n")
2415 (setq indent 2811 ;; Prepare indent for children.
2416 (cond 2812 (setq indent
2417 ((eq rst-toc-insert-style 'plain) 2813 (cond
2418 (concat indent (make-string rst-toc-indent ? ))) 2814 ((eq rst-toc-insert-style 'plain)
2419 2815 (concat indent (make-string rst-toc-indent ? )))
2420 ((eq rst-toc-insert-style 'fixed) 2816 ((eq rst-toc-insert-style 'fixed)
2421 (concat indent (make-string rst-toc-indent ? ))) 2817 (concat indent (make-string rst-toc-indent ? )))
2422 2818 ((eq rst-toc-insert-style 'aligned)
2423 ((eq rst-toc-insert-style 'aligned) 2819 (concat indent (make-string (+ (length pfx) 2) ? )))
2424 (concat indent (make-string (+ (length pfx) 2) ? ))) 2820 ((eq rst-toc-insert-style 'listed)
2425 2821 (concat (substring indent 0 -3)
2426 ((eq rst-toc-insert-style 'listed) 2822 (concat (make-string (+ (length pfx) 2) ? ) " - "))))))
2427 (concat (substring indent 0 -3) 2823 (when (or (eq rst-toc-insert-max-level nil)
2428 (concat (make-string (+ (length pfx) 2) ? ) " - ")))))) 2824 (< level rst-toc-insert-max-level))
2429 2825 (let ((count 1)
2430 (if (or (eq rst-toc-insert-max-level nil) 2826 fmt)
2431 (< level rst-toc-insert-max-level)) 2827 ;; Add a separating dot if there is already a prefix.
2432 (let ((do-child-numbering (>= level 0)) 2828 (when (> (length pfx) 0)
2433 fmt) 2829 (string-match (rst-re "[ \t\n]*\\'") pfx)
2434 (if do-child-numbering 2830 (setq pfx (concat (replace-match "" t t pfx) ".")))
2435 (progn 2831 ;; Calculate the amount of space that the prefix will require
2436 ;; Add a separating dot if there is already a prefix. 2832 ;; for the numbers.
2437 (when (> (length pfx) 0) 2833 (when (rst-Stn-children stn)
2438 (string-match (rst-re "[ \t\n]*\\'") pfx) 2834 (setq fmt
2439 (setq pfx (concat (replace-match "" t t pfx) "."))) 2835 (format "%%-%dd"
2440 2836 (1+ (floor (log (length (rst-Stn-children stn))
2441 ;; Calculate the amount of space that the prefix will require 2837 10))))))
2442 ;; for the numbers. 2838 (dolist (child (rst-Stn-children stn))
2443 (if (cdr node) 2839 (rst-toc-insert-node child (1+ level) indent
2444 (setq fmt (format "%%-%dd" 2840 (concat pfx (format fmt count)))
2445 (1+ (floor (log (length (cdr node)) 2841 (incf count)))))
2446 10))))))))
2447
2448 (dolist (child (cdr node))
2449 (rst-toc-insert-node child
2450 (1+ level)
2451 indent
2452 (if do-child-numbering
2453 (concat pfx (format fmt count)) pfx))
2454 (incf count))))))
2455
2456 2842
2457(defun rst-toc-update () 2843(defun rst-toc-update ()
2458 "Automatically find the contents section of a document and update. 2844 "Automatically find the contents section of a document and update.
@@ -2497,57 +2883,45 @@ file-write hook to always make it up-to-date automatically."
2497 ;; Note: always return nil, because this may be used as a hook. 2883 ;; Note: always return nil, because this may be used as a hook.
2498 nil) 2884 nil)
2499 2885
2500;; Note: we cannot bind the TOC update on file write because it messes with 2886;; FIXME: Updating the toc on saving would be nice. However, this doesn't work
2501;; undo. If we disable undo, since it adds and removes characters, the 2887;; correctly:
2502;; positions in the undo list are not making sense anymore. Dunno what to do
2503;; with this, it would be nice to update when saving.
2504;; 2888;;
2505;; (add-hook 'write-contents-hooks 'rst-toc-update-fun) 2889;; (add-hook 'write-contents-hooks 'rst-toc-update-fun)
2506;; (defun rst-toc-update-fun () 2890;; (defun rst-toc-update-fun ()
2507;; ;; Disable undo for the write file hook. 2891;; ;; Disable undo for the write file hook.
2508;; (let ((buffer-undo-list t)) (rst-toc-update) )) 2892;; (let ((buffer-undo-list t)) (rst-toc-update) ))
2509 2893
2510(defalias 'rst-toc-insert-update 'rst-toc-update) ; backwards compat. 2894(defalias 'rst-toc-insert-update 'rst-toc-update) ; backwards compat.
2511 2895
2512;;------------------------------------------------------------------------------ 2896(defun rst-toc-node (stn buf target)
2513 2897 "Insert STN in the table-of-contents of buffer BUF.
2514(defun rst-toc-node (node level) 2898If TARGET is given and this call renders a `rst-Stn' at the same
2515 "Recursive function that does insert NODE at LEVEL in the table-of-contents." 2899location return position of beginning of line. Otherwise return
2516 2900nil."
2517 (if (> level 0) 2901 (let ((beg (point))
2518 (let ((b (point))) 2902 fnd)
2519 ;; Insert line text. 2903 (if (or (not stn) (rst-Stn-is-top stn))
2520 (insert (make-string (* rst-toc-indent (1- level)) ? )) 2904 (progn
2521 (insert (or (caar node) "[missing node]")) 2905 (insert (format "Table of Contents:\n"))
2522 2906 (put-text-property beg (point)
2523 ;; Highlight lines. 2907 'face (list '(background-color . "gray"))))
2524 (put-text-property b (point) 'mouse-face 'highlight) 2908 (when (and target
2525 2909 (equal (rst-Stn-get-title-beginning stn)
2526 ;; Add link on lines. 2910 (rst-Stn-get-title-beginning target)))
2527 (put-text-property b (point) 'rst-toc-target (cadar node)) 2911 (setq fnd beg))
2528 2912 (insert (make-string (* rst-toc-indent (rst-Stn-level stn)) ? ))
2529 (insert "\n"))) 2913 (insert (rst-Stn-get-text stn))
2530 2914 ;; Highlight lines.
2531 (dolist (child (cdr node)) 2915 (put-text-property beg (point) 'mouse-face 'highlight)
2532 (rst-toc-node child (1+ level)))) 2916 (insert "\n")
2533 2917 ;; Add link on lines.
2534(defun rst-toc-count-lines (node target-node) 2918 (put-text-property
2535 "Count the number of lines from NODE to the TARGET-NODE node. 2919 beg (point) 'rst-toc-target
2536This recursive function returns a cons of the number of 2920 (set-marker (make-marker) (rst-Stn-get-title-beginning stn) buf)))
2537additional lines that have been counted for its node and 2921 (when stn
2538children, and t if the node has been found." 2922 (dolist (child (rst-Stn-children stn))
2539 2923 (setq fnd (or (rst-toc-node child buf target) fnd))))
2540 (let ((count 1) 2924 fnd))
2541 found)
2542 (if (eq node target-node)
2543 (setq found t)
2544 (let ((child (cdr node)))
2545 (while (and child (not found))
2546 (let ((cl (rst-toc-count-lines (car child) target-node)))
2547 (setq count (+ count (car cl))
2548 found (cdr cl)
2549 child (cdr child))))))
2550 (cons count found)))
2551 2925
2552(defvar rst-toc-buffer-name "*Table of Contents*" 2926(defvar rst-toc-buffer-name "*Table of Contents*"
2553 "Name of the Table of Contents buffer.") 2927 "Name of the Table of Contents buffer.")
@@ -2555,7 +2929,6 @@ children, and t if the node has been found."
2555(defvar rst-toc-return-wincfg nil 2929(defvar rst-toc-return-wincfg nil
2556 "Window configuration to which to return when leaving the TOC.") 2930 "Window configuration to which to return when leaving the TOC.")
2557 2931
2558
2559(defun rst-toc () 2932(defun rst-toc ()
2560 "Display a table-of-contents. 2933 "Display a table-of-contents.
2561Finds all the section titles and their adornments in the 2934Finds all the section titles and their adornments in the
@@ -2567,37 +2940,21 @@ The Emacs buffer can be navigated, and selecting a section
2567brings the cursor in that section." 2940brings the cursor in that section."
2568 (interactive) 2941 (interactive)
2569 (rst-reset-section-caches) 2942 (rst-reset-section-caches)
2570 (let* ((curbuf (list (current-window-configuration) (point-marker))) 2943 (let* ((wincfg (list (current-window-configuration) (point-marker)))
2571 (sectree (rst-section-tree)) 2944 (sectree (rst-all-stn))
2572 2945 (target-node (rst-stn-containing-point sectree))
2573 (our-node (cdr (rst-section-tree-point sectree))) 2946 (target-buf (current-buffer))
2574 line 2947 (buf (get-buffer-create rst-toc-buffer-name))
2575 2948 target-pos)
2576 ;; Create a temporary buffer.
2577 (buf (get-buffer-create rst-toc-buffer-name)))
2578
2579 (with-current-buffer buf 2949 (with-current-buffer buf
2580 (let ((inhibit-read-only t)) 2950 (let ((inhibit-read-only t))
2581 (rst-toc-mode) 2951 (rst-toc-mode)
2582 (delete-region (point-min) (point-max)) 2952 (delete-region (point-min) (point-max))
2583 (insert (format "Table of Contents: %s\n" (or (caar sectree) ""))) 2953 (setq target-pos (rst-toc-node sectree target-buf target-node))))
2584 (put-text-property (point-min) (point)
2585 'face (list '(background-color . "gray")))
2586 (rst-toc-node sectree 0)
2587
2588 ;; Count the lines to our found node.
2589 (let ((linefound (rst-toc-count-lines sectree our-node)))
2590 (setq line (if (cdr linefound) (car linefound) 0)))))
2591 (display-buffer buf) 2954 (display-buffer buf)
2592 (pop-to-buffer buf) 2955 (pop-to-buffer buf)
2593 2956 (setq-local rst-toc-return-wincfg wincfg)
2594 ;; Save the buffer to return to. 2957 (goto-char (or target-pos (point-min)))))
2595 (set (make-local-variable 'rst-toc-return-wincfg) curbuf)
2596
2597 ;; Move the cursor near the right section in the TOC.
2598 (goto-char (point-min))
2599 (forward-line (1- line))))
2600
2601 2958
2602(defun rst-toc-mode-find-section () 2959(defun rst-toc-mode-find-section ()
2603 "Get the section from text property at point." 2960 "Get the section from text property at point."
@@ -2660,10 +3017,12 @@ EVENT is the input event."
2660(defvar rst-toc-mode-map 3017(defvar rst-toc-mode-map
2661 (let ((map (make-sparse-keymap))) 3018 (let ((map (make-sparse-keymap)))
2662 (define-key map [mouse-1] 'rst-toc-mode-mouse-goto-kill) 3019 (define-key map [mouse-1] 'rst-toc-mode-mouse-goto-kill)
3020 ;; FIXME: This very useful function must be on some key.
2663 (define-key map [mouse-2] 'rst-toc-mode-mouse-goto) 3021 (define-key map [mouse-2] 'rst-toc-mode-mouse-goto)
2664 (define-key map "\C-m" 'rst-toc-mode-goto-section) 3022 (define-key map "\C-m" 'rst-toc-mode-goto-section)
2665 (define-key map "f" 'rst-toc-mode-goto-section) 3023 (define-key map "f" 'rst-toc-mode-goto-section)
2666 (define-key map "q" 'rst-toc-quit-window) 3024 (define-key map "q" 'rst-toc-quit-window)
3025 ;; FIXME: Killing should clean up like `rst-toc-quit-window' does.
2667 (define-key map "z" 'kill-this-buffer) 3026 (define-key map "z" 'kill-this-buffer)
2668 map) 3027 map)
2669 "Keymap for `rst-toc-mode'.") 3028 "Keymap for `rst-toc-mode'.")
@@ -2672,15 +3031,13 @@ EVENT is the input event."
2672 3031
2673;; Could inherit from the new `special-mode'. 3032;; Could inherit from the new `special-mode'.
2674(define-derived-mode rst-toc-mode nil "ReST-TOC" 3033(define-derived-mode rst-toc-mode nil "ReST-TOC"
2675 "Major mode for output from \\[rst-toc], the table-of-contents for the document." 3034 "Major mode for output from \\[rst-toc], the table-of-contents for the document.
2676 (setq buffer-read-only t))
2677 3035
2678;; Note: use occur-mode (replace.el) as a good example to complete missing 3036\\{rst-toc-mode-map}"
2679;; features. 3037 (setq buffer-read-only t))
2680 3038
2681;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3039;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2682;; Section movement commands 3040;; Section movement
2683;; =========================
2684 3041
2685(defun rst-forward-section (&optional offset) 3042(defun rst-forward-section (&optional offset)
2686 "Skip to the next reStructuredText section title. 3043 "Skip to the next reStructuredText section title.
@@ -2688,38 +3045,32 @@ OFFSET specifies how many titles to skip. Use a negative OFFSET
2688to move backwards in the file (default is to use 1)." 3045to move backwards in the file (default is to use 1)."
2689 (interactive) 3046 (interactive)
2690 (rst-reset-section-caches) 3047 (rst-reset-section-caches)
2691 (let* (;; Default value for offset. 3048 (let* ((offset (or offset 1))
2692 (offset (or offset 1)) 3049 (ttls (rst-all-ttls))
2693 3050 (curpos (line-beginning-position))
2694 ;; Get all the adornments in the file, with their line numbers. 3051 (cur ttls)
2695 (allados (rst-find-all-adornments)) 3052 (idx 0)
2696 3053 ttl)
2697 ;; Get the current line. 3054
2698 (curline (line-number-at-pos)) 3055 ;; Find the index of the "next" adornment with respect to the current line.
2699 3056 (while (and cur (< (rst-Ttl-get-title-beginning (car cur)) curpos))
2700 (cur allados)
2701 (idx 0))
2702
2703 ;; Find the index of the "next" adornment w.r.t. to the current line.
2704 (while (and cur (< (caar cur) curline))
2705 (setq cur (cdr cur)) 3057 (setq cur (cdr cur))
2706 (incf idx)) 3058 (incf idx))
2707 ;; 'cur' is the adornment on or following the current line. 3059 ;; `cur' is the `rst-Ttl' on or following the current line.
2708 3060
2709 (if (and (> offset 0) cur (= (caar cur) curline)) 3061 (if (and (> offset 0) cur
3062 (equal (rst-Ttl-get-title-beginning (car cur)) curpos))
2710 (incf idx)) 3063 (incf idx))
2711 3064
2712 ;; Find the final index. 3065 ;; Find the final index.
2713 (setq idx (+ idx (if (> offset 0) (- offset 1) offset))) 3066 (setq idx (+ idx (if (> offset 0) (- offset 1) offset)))
2714 (setq cur (nth idx allados)) 3067 (setq ttl (nth idx ttls))
2715 3068 (goto-char (cond
2716 ;; If the index is positive, goto the line, otherwise go to the buffer 3069 ((and ttl (>= idx 0))
2717 ;; boundaries. 3070 (rst-Ttl-get-title-beginning ttl))
2718 (if (and cur (>= idx 0)) 3071 ((> offset 0)
2719 (progn 3072 (point-max))
2720 (goto-char (point-min)) 3073 ((point-min))))))
2721 (forward-line (1- (car cur))))
2722 (if (> offset 0) (goto-char (point-max)) (goto-char (point-min))))))
2723 3074
2724(defun rst-backward-section () 3075(defun rst-backward-section ()
2725 "Like `rst-forward-section', except move back one title." 3076 "Like `rst-forward-section', except move back one title."
@@ -2751,11 +3102,13 @@ for negative COUNT."
2751 3102
2752 3103
2753;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3104;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2754;; Functions to work on item lists (e.g. indent/dedent, enumerate), which are 3105;; Indentation
2755;; always 2 or 3 characters apart horizontally with rest.
2756 3106
2757(defun rst-find-leftmost-column (beg end) 3107(defun rst-find-leftmost-column (beg end)
2758 "Return the leftmost column in region BEG to END." 3108 "Return the leftmost column spanned by region BEG to END.
3109The line containing the start of the region is always considered
3110spanned. If the region ends at the beginning of a line this line
3111is not considered spanned, otherwise it is spanned."
2759 (let (mincol) 3112 (let (mincol)
2760 (save-excursion 3113 (save-excursion
2761 (goto-char beg) 3114 (goto-char beg)
@@ -2768,80 +3121,6 @@ for negative COUNT."
2768 (forward-line 1))) 3121 (forward-line 1)))
2769 mincol)) 3122 mincol))
2770 3123
2771;; FIXME: This definition is old and deprecated. We need to move to the newer
2772;; version below.
2773(defmacro rst-iterate-leftmost-paragraphs
2774 (beg end first-only body-consequent body-alternative)
2775 ;; FIXME: The following comment is pretty useless.
2776 "Call FUN at the beginning of each line, with an argument that
2777specifies whether we are at the first line of a paragraph that
2778starts at the leftmost column of the given region BEG and END.
2779Set FIRST-ONLY to true if you want to callback on the first line
2780of each paragraph only."
2781 `(save-excursion
2782 (let ((leftcol (rst-find-leftmost-column ,beg ,end))
2783 (endm (copy-marker ,end)))
2784
2785 (do* (;; Iterate lines.
2786 (l (progn (goto-char ,beg) (back-to-indentation))
2787 (progn (forward-line 1) (back-to-indentation)))
2788
2789 (previous nil valid)
2790
2791 (curcol (current-column)
2792 (current-column))
2793
2794 (valid (and (= curcol leftcol)
2795 (not (looking-at (rst-re 'lin-end))))
2796 (and (= curcol leftcol)
2797 (not (looking-at (rst-re 'lin-end))))))
2798 ((>= (point) endm))
2799
2800 (if (if ,first-only
2801 (and valid (not previous))
2802 valid)
2803 ,body-consequent
2804 ,body-alternative)))))
2805
2806;; FIXME: This needs to be refactored. Probably this is simply a function
2807;; applying BODY rather than a macro.
2808(defmacro rst-iterate-leftmost-paragraphs-2 (spec &rest body)
2809 "Evaluate BODY for each line in region defined by BEG END.
2810LEFTMOST is set to true if the line is one of the leftmost of the
2811entire paragraph. PARABEGIN is set to true if the line is the
2812first of a paragraph."
2813 (declare (indent 1) (debug (sexp body)))
2814 (destructuring-bind
2815 (beg end parabegin leftmost isleftmost isempty) spec
2816
2817 `(save-excursion
2818 (let ((,leftmost (rst-find-leftmost-column ,beg ,end))
2819 (endm (copy-marker ,end)))
2820
2821 (do* (;; Iterate lines.
2822 (l (progn (goto-char ,beg) (back-to-indentation))
2823 (progn (forward-line 1) (back-to-indentation)))
2824
2825 (empty-line-previous nil ,isempty)
2826
2827 (,isempty (looking-at (rst-re 'lin-end))
2828 (looking-at (rst-re 'lin-end)))
2829
2830 (,parabegin (not ,isempty)
2831 (and empty-line-previous
2832 (not ,isempty)))
2833
2834 (,isleftmost (and (not ,isempty)
2835 (= (current-column) ,leftmost))
2836 (and (not ,isempty)
2837 (= (current-column) ,leftmost))))
2838 ((>= (point) endm))
2839
2840 (progn ,@body))))))
2841
2842;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2843;; Indentation
2844
2845;; FIXME: At the moment only block comments with leading empty comment line are 3124;; FIXME: At the moment only block comments with leading empty comment line are
2846;; supported. Comment lines with leading comment markup should be also 3125;; supported. Comment lines with leading comment markup should be also
2847;; supported. May be a customizable option could control which style to 3126;; supported. May be a customizable option could control which style to
@@ -3052,7 +3331,7 @@ above. If no suitable tab is found `rst-indent-width' is used."
3052 (abs (abs cnt)) ; Absolute number of steps to take. 3331 (abs (abs cnt)) ; Absolute number of steps to take.
3053 ;; Get the position of the first tab beyond leftmostcol. 3332 ;; Get the position of the first tab beyond leftmostcol.
3054 (fnd (lexical-let ((cmp cmp) 3333 (fnd (lexical-let ((cmp cmp)
3055 (leftmostcol leftmostcol)) ; Create closure. 3334 (leftmostcol leftmostcol)) ;; Create closure.
3056 (rst-position-if (lambda (elt) 3335 (rst-position-if (lambda (elt)
3057 (funcall cmp elt leftmostcol)) 3336 (funcall cmp elt leftmostcol))
3058 tabs))) 3337 tabs)))
@@ -3139,7 +3418,7 @@ Region is from BEG to END. Uncomment if ARG."
3139 3418
3140(defun rst-uncomment-region (beg end &optional _arg) 3419(defun rst-uncomment-region (beg end &optional _arg)
3141 "Uncomment the current region. 3420 "Uncomment the current region.
3142Region is from BEG to END. ARG is ignored" 3421Region is from BEG to END. _ARG is ignored"
3143 (save-excursion 3422 (save-excursion
3144 (let (bol eol) 3423 (let (bol eol)
3145 (goto-char beg) 3424 (goto-char beg)
@@ -3150,7 +3429,8 @@ Region is from BEG to END. ARG is ignored"
3150 (indent-rigidly eol end (- rst-indent-comment)) 3429 (indent-rigidly eol end (- rst-indent-comment))
3151 (delete-region bol eol)))) 3430 (delete-region bol eol))))
3152 3431
3153;;------------------------------------------------------------------------------ 3432;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3433;; Apply to indented block
3154 3434
3155;; FIXME: These next functions should become part of a larger effort to redo 3435;; FIXME: These next functions should become part of a larger effort to redo
3156;; the bullets in bulleted lists. The enumerate would just be one of 3436;; the bullets in bulleted lists. The enumerate would just be one of
@@ -3158,29 +3438,127 @@ Region is from BEG to END. ARG is ignored"
3158;; 3438;;
3159;; FIXME: We need to do the enumeration removal as well. 3439;; FIXME: We need to do the enumeration removal as well.
3160 3440
3441(defun rst-apply-indented-blocks (beg end ind fun)
3442 "Apply FUN to all lines from BEG to END in blocks indented to IND.
3443The first indented block starts with the first non-empty line
3444containing or after BEG and indented to IND. After the first
3445line the indented block may contain more lines with same
3446indentation (the paragraph) followed by empty lines and lines
3447more indented (the sub-blocks). A following line indented to IND
3448starts the next indented block. A line with less indentation
3449than IND terminates the current indented block. Such lines and
3450all following lines not indented to IND are skipped. FUN is
3451applied to unskipped lines like this
3452
3453 (FUN COUNT FIRSTP SUBP EMPTYP RELIND LASTRET)
3454
3455COUNT is 0 before the first indented block and increments for
3456every indented block found.
3457
3458FIRSTP is t when this is the first line of the paragraph.
3459
3460SUBP is t when this line is part of a sub-block.
3461
3462EMPTYP is t when this line is empty.
3463
3464RELIND is nil for an empty line, 0 for a line indented to IND,
3465and the number of columns more indented otherwise.
3466
3467LASTRET is the return value of FUN returned by the last
3468invocation for the same indented block or nil for the first
3469invocation.
3470
3471When FUN is called point is immediately behind indentation of
3472that line. FUN may change everything as long as a marker at END
3473is handled correctly by the change.
3474
3475Return the return value of the last invocation of FUN or nil if
3476FUN was never called."
3477 (let (lastret
3478 subp
3479 skipping
3480 nextm
3481 (count 0) ; Before first indented block
3482 (endm (copy-marker end t)))
3483 (save-excursion
3484 (goto-char beg)
3485 (while (< (point) endm)
3486 (save-excursion
3487 (setq nextm (save-excursion
3488 (forward-line 1)
3489 (copy-marker (point) t)))
3490 (back-to-indentation)
3491 (let (firstp
3492 emptyp
3493 (relind (- (current-column) ind)))
3494 (cond
3495 ((looking-at (rst-re 'lin-end))
3496 (setq emptyp t)
3497 (setq relind nil)
3498 ;; Breaks indented block if one is started
3499 (setq subp (not (zerop count))))
3500 ((< relind 0) ; Less indented
3501 (setq skipping t))
3502 ((zerop relind) ; In indented block
3503 (when (or subp skipping (zerop count))
3504 (setq firstp t)
3505 (incf count))
3506 (setq subp nil)
3507 (setq skipping nil))
3508 (t ; More indented
3509 (setq subp t)))
3510 (unless skipping
3511 (setq lastret
3512 (funcall fun count firstp subp emptyp relind lastret)))))
3513 (goto-char nextm))
3514 lastret)))
3515
3161(defun rst-enumerate-region (beg end all) 3516(defun rst-enumerate-region (beg end all)
3162 "Add enumeration to all the leftmost paragraphs in the given region. 3517 "Add enumeration to all the leftmost paragraphs in the given region.
3163The region is specified between BEG and END. With ALL, 3518The region is specified between BEG and END. With ALL,
3164do all lines instead of just paragraphs." 3519do all lines instead of just paragraphs."
3165 (interactive "r\nP") 3520 (interactive "r\nP")
3166 (let ((count 0) 3521 (let ((enum 0))
3167 (last-insert-len nil)) 3522 (rst-apply-indented-blocks
3168 (rst-iterate-leftmost-paragraphs 3523 beg end (rst-find-leftmost-column beg end)
3169 beg end (not all) 3524 (lambda (count firstp subp emptyp relind lastret)
3170 (let ((ins-string (format "%d. " (incf count)))) 3525 (cond
3171 (setq last-insert-len (length ins-string)) 3526 (emptyp)
3172 (insert ins-string)) 3527 ((zerop count))
3173 (insert (make-string last-insert-len ?\ ))))) 3528 (subp
3529 (insert lastret))
3530 ((or firstp all)
3531 (let ((ins (format "%d. " (incf enum))))
3532 (setq lastret (make-string (length ins) ?\ ))
3533 (insert ins)))
3534 (t
3535 (insert lastret)))
3536 lastret))))
3174 3537
3538;; FIXME: Does not deal with deeper indentation - although
3539;; `rst-apply-indented-blocks' could.
3175(defun rst-bullet-list-region (beg end all) 3540(defun rst-bullet-list-region (beg end all)
3176 "Add bullets to all the leftmost paragraphs in the given region. 3541 "Add bullets to all the leftmost paragraphs in the given region.
3177The region is specified between BEG and END. With ALL, 3542The region is specified between BEG and END. With ALL,
3178do all lines instead of just paragraphs." 3543do all lines instead of just paragraphs."
3179 (interactive "r\nP") 3544 (interactive "r\nP")
3180 (rst-iterate-leftmost-paragraphs 3545 (unless rst-preferred-bullets
3181 beg end (not all) 3546 (error "No preferred bullets defined"))
3182 (insert (car rst-preferred-bullets) " ") 3547 (let ((bul (format "%c " (car rst-preferred-bullets)))
3183 (insert " "))) 3548 (cont " "))
3549 (rst-apply-indented-blocks
3550 beg end (rst-find-leftmost-column beg end)
3551 (lambda (count firstp subp emptyp relind lastret)
3552 (cond
3553 (emptyp)
3554 ((zerop count))
3555 (subp
3556 (insert cont))
3557 ((or firstp all)
3558 (insert bul))
3559 (t
3560 (insert cont)))
3561 nil))))
3184 3562
3185;; FIXME: Does not deal with a varying number of digits appropriately. 3563;; FIXME: Does not deal with a varying number of digits appropriately.
3186;; FIXME: Does not deal with multiple levels independently. 3564;; FIXME: Does not deal with multiple levels independently.
@@ -3203,29 +3581,21 @@ Renumber as necessary. Region is from BEG to END."
3203 (replace-match (format "%d." count) nil nil nil 1) 3581 (replace-match (format "%d." count) nil nil nil 1)
3204 (incf count))))) 3582 (incf count)))))
3205 3583
3206;;------------------------------------------------------------------------------ 3584(defun rst-line-block-region (beg end &optional with-empty)
3207 3585 "Add line block prefixes for a region.
3208(defun rst-line-block-region (rbeg rend &optional pfxarg) 3586Region is from BEG to END. With WITH-EMPTY prefix empty lines too."
3209 "Toggle line block prefixes for a region.
3210Region is from RBEG to REND. With PFXARG set the empty lines too."
3211 (interactive "r\nP") 3587 (interactive "r\nP")
3212 (let ((comment-start "| ") 3588 (let ((ind (rst-find-leftmost-column beg end)))
3213 (comment-end "") 3589 (rst-apply-indented-blocks
3214 (comment-start-skip "| ") 3590 beg end ind
3215 (comment-style 'indent) 3591 (lambda (count firstp subp emptyp relind lastret)
3216 (force (not (not pfxarg)))) 3592 (when (or with-empty (not emptyp))
3217 (rst-iterate-leftmost-paragraphs-2 3593 (move-to-column ind t)
3218 (rbeg rend parbegin leftmost isleft isempty) 3594 (insert "| "))))))
3219 (when (or force (not isempty))
3220 (move-to-column leftmost force)
3221 (delete-region (point) (+ (point) (- (current-indentation) leftmost)))
3222 (insert "| ")))))
3223
3224 3595
3225 3596
3226;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3597;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3227;; Font lock 3598;; Font lock
3228;; =========
3229 3599
3230(require 'font-lock) 3600(require 'font-lock)
3231 3601
@@ -3525,7 +3895,7 @@ of your own."
3525 (,(rst-re 'ilm-pfx '(:grp "_`" ilcbkq-tag "`") 'ilm-sfx) 3895 (,(rst-re 'ilm-pfx '(:grp "_`" ilcbkq-tag "`") 'ilm-sfx)
3526 1 rst-definition-face) 3896 1 rst-definition-face)
3527 ;; `Hyperlink References`_ 3897 ;; `Hyperlink References`_
3528 ;; FIXME: `Embedded URIs`_ not considered. 3898 ;; FIXME: `Embedded URIs and Aliases`_ not considered.
3529 ;; FIXME: Directly adjacent marked up words are not fontified correctly 3899 ;; FIXME: Directly adjacent marked up words are not fontified correctly
3530 ;; unless they are not separated by two spaces: foo_ bar_. 3900 ;; unless they are not separated by two spaces: foo_ bar_.
3531 (,(rst-re 'ilm-pfx '(:grp (:alt (:seq "`" ilcbkq-tag "`") 3901 (,(rst-re 'ilm-pfx '(:grp (:alt (:seq "`" ilcbkq-tag "`")
@@ -3714,9 +4084,9 @@ Return extended point or nil if not moved."
3714 (if (looking-at (rst-re 'ado-beg-2-1)) ; may be an underline / 4084 (if (looking-at (rst-re 'ado-beg-2-1)) ; may be an underline /
3715 ; overline. 4085 ; overline.
3716 (if (zerop (rst-forward-line dir)) 4086 (if (zerop (rst-forward-line dir))
3717 (if (looking-at (rst-re 'ttl-beg)) ; title found, i.e. 4087 (if (looking-at (rst-re 'ttl-beg-1)) ; title found, i.e.
3718 ; underline / overline 4088 ; underline / overline
3719 ; found. 4089 ; found.
3720 (if (zerop (rst-forward-line dir)) 4090 (if (zerop (rst-forward-line dir))
3721 (if (not 4091 (if (not
3722 (looking-at (rst-re 'ado-beg-2-1))) ; no 4092 (looking-at (rst-re 'ado-beg-2-1))) ; no
@@ -3726,7 +4096,7 @@ Return extended point or nil if not moved."
3726 ; / adornment. 4096 ; / adornment.
3727 (if (< dir 0) ; keep downward adornment. 4097 (if (< dir 0) ; keep downward adornment.
3728 (rst-forward-line (- dir))))) ; step back to adornment. 4098 (rst-forward-line (- dir))))) ; step back to adornment.
3729 (if (looking-at (rst-re 'ttl-beg)) ; may be a title. 4099 (if (looking-at (rst-re 'ttl-beg-1)) ; may be a title.
3730 (if (zerop (rst-forward-line dir)) 4100 (if (zerop (rst-forward-line dir))
3731 (if (not 4101 (if (not
3732 (looking-at (rst-re 'ado-beg-2-1))) ; no overline / 4102 (looking-at (rst-re 'ado-beg-2-1))) ; no overline /
@@ -3827,7 +4197,7 @@ next non-empty line if this is indented more than the current one."
3827 "Set the match found earlier if match were found. 4197 "Set the match found earlier if match were found.
3828Match has been found by `rst-font-lock-find-unindented-line-limit' 4198Match has been found by `rst-font-lock-find-unindented-line-limit'
3829the first time called or no match is found. Return non-nil if 4199the first time called or no match is found. Return non-nil if
3830match was found. LIMIT is not used but mandated by the caller." 4200match was found. _LIMIT is not used but mandated by the caller."
3831 (when rst-font-lock-find-unindented-line-end 4201 (when rst-font-lock-find-unindented-line-end
3832 (set-match-data 4202 (set-match-data
3833 (list rst-font-lock-find-unindented-line-begin 4203 (list rst-font-lock-find-unindented-line-begin
@@ -3846,22 +4216,14 @@ match was found. LIMIT is not used but mandated by the caller."
3846 "Storage for `rst-font-lock-handle-adornment-matcher'. 4216 "Storage for `rst-font-lock-handle-adornment-matcher'.
3847Either section level of the current adornment or t for a transition.") 4217Either section level of the current adornment or t for a transition.")
3848 4218
3849(defun rst-adornment-level (key) 4219(defun rst-adornment-level (ado)
3850 "Return section level for adornment KEY. 4220 "Return section level for ADO or t for a transition.
3851KEY is the first element of the return list of `rst-classify-adornment'. 4221If ADO is found in the hierarchy return its level. Otherwise
3852If KEY is not a cons return it. If KEY is found in the hierarchy return 4222return a level one beyond the existing hierarchy."
3853its level. Otherwise return a level one beyond the existing hierarchy." 4223 (if (rst-Ado-is-transition ado)
3854 (if (not (consp key)) 4224 t
3855 key 4225 (let ((hier (rst-Hdr-ado-map (rst-hdr-hierarchy))))
3856 (let* ((hier (rst-get-hierarchy)) 4226 (1+ (or (rst-Ado-position ado hier)
3857 (char (car key))
3858 (style (cdr key)))
3859 (1+ (or (lexical-let ((char char)
3860 (style style)
3861 (hier hier)) ; Create closure.
3862 (rst-position-if (lambda (elt)
3863 (and (equal (car elt) char)
3864 (equal (cadr elt) style))) hier))
3865 (length hier)))))) 4227 (length hier))))))
3866 4228
3867(defvar rst-font-lock-adornment-match nil 4229(defvar rst-font-lock-adornment-match nil
@@ -3878,15 +4240,15 @@ matched. ADO-END is the point where ADO ends. Return the point
3878where the whole adorned construct ends. 4240where the whole adorned construct ends.
3879 4241
3880Called as a PRE-MATCH-FORM in the sense of `font-lock-keywords'." 4242Called as a PRE-MATCH-FORM in the sense of `font-lock-keywords'."
3881 (let ((ado-data (rst-classify-adornment ado ado-end))) 4243 (let ((ttl (rst-classify-adornment ado ado-end)))
3882 (if (not ado-data) 4244 (if (not ttl)
3883 (setq rst-font-lock-adornment-level nil 4245 (setq rst-font-lock-adornment-level nil
3884 rst-font-lock-adornment-match nil) 4246 rst-font-lock-adornment-match nil)
3885 (setq rst-font-lock-adornment-level 4247 (setq rst-font-lock-adornment-level
3886 (rst-adornment-level (car ado-data))) 4248 (rst-adornment-level (rst-Ttl-ado ttl)))
3887 (setq rst-font-lock-adornment-match (cdr ado-data)) 4249 (setq rst-font-lock-adornment-match (rst-Ttl-match ttl))
3888 (goto-char (nth 1 ado-data)) ; Beginning of construct. 4250 (goto-char (rst-Ttl-get-beginning ttl))
3889 (nth 2 ado-data)))) ; End of construct. 4251 (rst-Ttl-get-end ttl))))
3890 4252
3891(defun rst-font-lock-handle-adornment-matcher (_limit) 4253(defun rst-font-lock-handle-adornment-matcher (_limit)
3892 "Set the match found earlier if match were found. 4254 "Set the match found earlier if match were found.
@@ -3895,7 +4257,7 @@ Match has been found by
3895called or no match is found. Return non-nil if match was found. 4257called or no match is found. Return non-nil if match was found.
3896 4258
3897Called as a MATCHER in the sense of `font-lock-keywords'. 4259Called as a MATCHER in the sense of `font-lock-keywords'.
3898LIMIT is not used but mandated by the caller." 4260_LIMIT is not used but mandated by the caller."
3899 (let ((match rst-font-lock-adornment-match)) 4261 (let ((match rst-font-lock-adornment-match))
3900 ;; May run only once - enforce this. 4262 ;; May run only once - enforce this.
3901 (setq rst-font-lock-adornment-match nil) 4263 (setq rst-font-lock-adornment-match nil)
@@ -3933,6 +4295,13 @@ document with \\[rst-compile]."
3933 ".pdf" nil) 4295 ".pdf" nil)
3934 (s5 ,(if (executable-find "rst2s5.py") "rst2s5.py" "rst2s5") 4296 (s5 ,(if (executable-find "rst2s5.py") "rst2s5.py" "rst2s5")
3935 ".html" nil)) 4297 ".html" nil))
4298 ;; FIXME: Add at least those converters officially supported like `rst2odt'
4299 ;; and `rst2man'.
4300 ;; FIXME: To make this really useful there should be a generic command the
4301 ;; user gives one of the symbols and this way select the conversion to
4302 ;; run. This should replace the toolset stuff somehow.
4303 ;; FIXME: Allow a template for the conversion command so `rst2pdf ... -o ...'
4304 ;; can be supported.
3936 "Table describing the command to use for each tool-set. 4305 "Table describing the command to use for each tool-set.
3937An association list of the tool-set to a list of the (command to use, 4306An association list of the tool-set to a list of the (command to use,
3938extension of produced filename, options to the tool (nil or a 4307extension of produced filename, options to the tool (nil or a
@@ -4002,16 +4371,17 @@ select the alternative tool-set."
4002 (outname (file-name-sans-extension bufname))) 4371 (outname (file-name-sans-extension bufname)))
4003 4372
4004 ;; Set compile-command before invocation of compile. 4373 ;; Set compile-command before invocation of compile.
4005 (set (make-local-variable 'compile-command) 4374 (setq-local
4006 (mapconcat 'identity 4375 compile-command
4007 (list command 4376 (mapconcat 'identity
4008 (or options "") 4377 (list command
4009 (if conffile 4378 (or options "")
4010 (concat "--config=" (shell-quote-argument conffile)) 4379 (if conffile
4011 "") 4380 (concat "--config=" (shell-quote-argument conffile))
4012 (shell-quote-argument bufname) 4381 "")
4013 (shell-quote-argument (concat outname extension))) 4382 (shell-quote-argument bufname)
4014 " ")) 4383 (shell-quote-argument (concat outname extension)))
4384 " "))
4015 4385
4016 ;; Invoke the compile command. 4386 ;; Invoke the compile command.
4017 (if (or compilation-read-command use-alt) 4387 (if (or compilation-read-command use-alt)
@@ -4036,7 +4406,7 @@ buffer, if the region is not selected."
4036 (cadr (assq 'pseudoxml rst-compile-toolsets)) 4406 (cadr (assq 'pseudoxml rst-compile-toolsets))
4037 standard-output))) 4407 standard-output)))
4038 4408
4039;; FIXME: Should be defcustom. 4409;; FIXME: Should be integrated in `rst-compile-toolsets'.
4040(defvar rst-pdf-program "xpdf" 4410(defvar rst-pdf-program "xpdf"
4041 "Program used to preview PDF files.") 4411 "Program used to preview PDF files.")
4042 4412
@@ -4053,7 +4423,8 @@ buffer, if the region is not selected."
4053 ;; output. 4423 ;; output.
4054 )) 4424 ))
4055 4425
4056;; FIXME: Should be defcustom or use something like `browse-url'. 4426;; FIXME: Should be integrated in `rst-compile-toolsets' defaulting to
4427;; something like `browse-url'.
4057(defvar rst-slides-program "firefox" 4428(defvar rst-slides-program "firefox"
4058 "Program used to preview S5 slides.") 4429 "Program used to preview S5 slides.")
4059 4430
@@ -4070,56 +4441,41 @@ buffer, if the region is not selected."
4070 ;; output. 4441 ;; output.
4071 )) 4442 ))
4072 4443
4444;; FIXME: Add `rst-compile-html-preview'.
4445
4073 4446
4074;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4447;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4075;; Imenu support. 4448;; Imenu support
4076 4449
4077;; FIXME: Integrate this properly. Consider a key binding. 4450;; FIXME: Consider a key binding. A key binding needs to definitely switch on
4078 4451;; `which-func-mode' - i.e. `which-func-modes' must be set properly.
4079;; Based on code from Masatake YAMATO <yamato@redhat.com>. 4452
4080 4453;; Based on ideas from Masatake YAMATO <yamato@redhat.com>.
4081(defun rst-imenu-find-adornments-for-position (adornments pos) 4454
4082 "Find adornments cell in ADORNMENTS for position POS." 4455(defun rst-imenu-convert-cell (stn)
4083 (let ((a nil)) 4456 "Convert a STN to an Imenu index node and return it."
4084 (while adornments 4457 (let ((ttl (rst-Stn-ttl stn))
4085 (if (and (car adornments) 4458 (children (rst-Stn-children stn))
4086 (eq (car (car adornments)) pos)) 4459 (pos (rst-Stn-get-title-beginning stn))
4087 (setq a adornments 4460 (txt (rst-Stn-get-text stn ""))
4088 adornments nil) 4461 (pfx " ")
4089 (setq adornments (cdr adornments)))) 4462 (sfx "")
4090 a)) 4463 name)
4091 4464 (when ttl
4092(defun rst-imenu-convert-cell (elt adornments) 4465 (let ((hdr (rst-Ttl-hdr ttl)))
4093 "Convert a cell ELT in a tree returned from `rst-section-tree' to Imenu index. 4466 (setq pfx (char-to-string (rst-Hdr-get-char hdr)))
4094ADORNMENTS is used as hint information for conversion." 4467 (when (rst-Hdr-is-over-and-under hdr)
4095 (let* ((kar (car elt)) 4468 (setq sfx pfx))))
4096 (kdr (cdr elt)) 4469 ;; FIXME: Overline adornment characters need to be in front so they
4097 (title (car kar))) 4470 ;; become visible even for long title lines. May be an additional
4098 (if kar 4471 ;; level number is also useful.
4099 (let* ((p (marker-position (cadr kar))) 4472 (setq name (format "%s%s%s" pfx txt sfx))
4100 (adornments 4473 (cons name ;; The name of the entry.
4101 (rst-imenu-find-adornments-for-position adornments p)) 4474 (if children
4102 (a (car adornments)) 4475 (cons ;; The entry has a submenu.
4103 (adornments (cdr adornments)) 4476 (cons name pos) ;; The entry itself.
4104 ;; FIXME: Overline adornment characters need to be in front so 4477 (mapcar 'rst-imenu-convert-cell children)) ;; The children.
4105 ;; they become visible even for long title lines. May be 4478 pos)))) ;; The position of a plain entry.
4106 ;; an additional level number is also useful.
4107 (title (format "%s%s%s"
4108 (make-string (1+ (nth 3 a)) (nth 1 a))
4109 title
4110 (if (eq (nth 2 a) 'simple)
4111 ""
4112 (char-to-string (nth 1 a))))))
4113 (cons title
4114 (if (null kdr)
4115 p
4116 (cons
4117 ;; A bit ugly but this make which-func happy.
4118 (cons title p)
4119 (mapcar (lambda (elt0)
4120 (rst-imenu-convert-cell elt0 adornments))
4121 kdr)))))
4122 nil)))
4123 4479
4124;; FIXME: Document title and subtitle need to be handled properly. They should 4480;; FIXME: Document title and subtitle need to be handled properly. They should
4125;; get an own "Document" top level entry. 4481;; get an own "Document" top level entry.
@@ -4127,25 +4483,13 @@ ADORNMENTS is used as hint information for conversion."
4127 "Create index for Imenu. 4483 "Create index for Imenu.
4128Return as described for `imenu--index-alist'." 4484Return as described for `imenu--index-alist'."
4129 (rst-reset-section-caches) 4485 (rst-reset-section-caches)
4130 (let ((tree (rst-section-tree)) 4486 (let ((root (rst-all-stn)))
4131 ;; Translate line notation to point notation. 4487 (when root
4132 (adornments (save-excursion 4488 (mapcar 'rst-imenu-convert-cell (rst-Stn-children root)))))
4133 (mapcar (lambda (ln-ado)
4134 (cons (progn
4135 (goto-char (point-min))
4136 (forward-line (1- (car ln-ado)))
4137 ;; FIXME: Need to consider
4138 ;; `imenu-use-markers' here?
4139 (point))
4140 (cdr ln-ado)))
4141 (rst-find-all-adornments)))))
4142 (delete nil (mapcar (lambda (elt)
4143 (rst-imenu-convert-cell elt adornments))
4144 tree))))
4145 4489
4146 4490
4147;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4491;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4148;; Generic text functions that are more convenient than the defaults. 4492;; Convenience functions
4149 4493
4150;; FIXME: Unbound command - should be bound or removed. 4494;; FIXME: Unbound command - should be bound or removed.
4151(defun rst-replace-lines (fromchar tochar) 4495(defun rst-replace-lines (fromchar tochar)
@@ -4228,12 +4572,12 @@ column is used (fill-column vs. end of previous/next line)."
4228 4572
4229;; LocalWords: docutils http sourceforge rst html wp svn svnroot txt reST regex 4573;; LocalWords: docutils http sourceforge rst html wp svn svnroot txt reST regex
4230;; LocalWords: regexes alist seq alt grp keymap abbrev overline overlines toc 4574;; LocalWords: regexes alist seq alt grp keymap abbrev overline overlines toc
4231;; LocalWords: XML PNT propertized 4575;; LocalWords: XML PNT propertized init referenceable
4576
4577(provide 'rst)
4232 4578
4233;; Local Variables: 4579;; Local Variables:
4234;; sentence-end-double-space: t 4580;; sentence-end-double-space: t
4235;; End: 4581;; End:
4236 4582
4237(provide 'rst)
4238
4239;;; rst.el ends here 4583;;; rst.el ends here