aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--lisp/textmodes/rst.el3153
1 files changed, 1593 insertions, 1560 deletions
diff --git a/lisp/textmodes/rst.el b/lisp/textmodes/rst.el
index 90c1f4539d7..edc48850609 100644
--- a/lisp/textmodes/rst.el
+++ b/lisp/textmodes/rst.el
@@ -1,4 +1,4 @@
1;;; rst.el --- Mode for viewing and editing reStructuredText-documents. 1;;; rst.el --- Mode for viewing and editing reStructuredText-documents -*- lexical-binding: t -*-
2 2
3;; Copyright (C) 2003-2017 Free Software Foundation, Inc. 3;; Copyright (C) 2003-2017 Free Software Foundation, Inc.
4 4
@@ -100,15 +100,30 @@
100 100
101;; FIXME: Check through major mode conventions again. 101;; FIXME: Check through major mode conventions again.
102 102
103;; FIXME: Add proper ";;;###autoload" comments.
104
105;; FIXME: When 24.1 is common place remove use of `lexical-let' and put "-*-
106;; lexical-binding: t -*-" in the first line.
107
108;; FIXME: Embed complicated `defconst's in `eval-when-compile'. 103;; FIXME: Embed complicated `defconst's in `eval-when-compile'.
109 104
110;; FIXME: Use `testcover'. Mark up a function with sufficient test coverage by 105;; Common Lisp stuff
111;; a comment tagged with `testcover' after the `defun'. 106(require 'cl-lib)
107
108;; Correct wrong declaration.
109(def-edebug-spec push
110 (&or [form symbolp] [form gv-place]))
111
112;; Correct wrong declaration. This still doesn't support dotted desctructuring
113;; though.
114(def-edebug-spec cl-lambda-list
115 (([&rest cl-macro-arg]
116 [&optional ["&optional" cl-&optional-arg &rest cl-&optional-arg]]
117 [&optional ["&rest" arg]]
118 [&optional ["&key" [cl-&key-arg &rest cl-&key-arg]
119 &optional "&allow-other-keys"]]
120 [&optional ["&aux" &rest
121 &or (symbolp &optional def-form) symbolp]]
122 )))
123
124;; Add missing declaration.
125(def-edebug-spec cl-type-spec sexp) ;; This is not exactly correct but good
126 ;; enough.
112 127
113;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 128;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
114;; Support for `testcover' 129;; Support for `testcover'
@@ -129,9 +144,9 @@ considered constants. Revert it with this function after each `defcustom'."
129 (setq testcover-module-constants 144 (setq testcover-module-constants
130 (delq nil 145 (delq nil
131 (mapcar 146 (mapcar
132 (lambda (sym) 147 #'(lambda (sym)
133 (if (not (plist-member (symbol-plist sym) 'standard-value)) 148 (if (not (plist-member (symbol-plist sym) 'standard-value))
134 sym)) 149 sym))
135 testcover-module-constants))))) 150 testcover-module-constants)))))
136 151
137(defun rst-testcover-add-compose (fun) 152(defun rst-testcover-add-compose (fun)
@@ -144,69 +159,72 @@ considered constants. Revert it with this function after each `defcustom'."
144 (when (boundp 'testcover-1value-functions) 159 (when (boundp 'testcover-1value-functions)
145 (add-to-list 'testcover-1value-functions fun))) 160 (add-to-list 'testcover-1value-functions fun)))
146 161
162
147;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 163;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
148;; Common Lisp stuff 164;; Helpers.
149 165
150;; Only use of macros is allowed - may be replaced by `cl-lib' some time. 166(cl-defmacro rst-destructuring-dolist
151(eval-when-compile 167 ((arglist list &optional result) &rest body)
152 (require 'cl)) 168 "`cl-dolist' with destructuring of the list elements.
153 169ARGLIST is a Common List argument list which may include
154;; Redefine some functions from `cl.el' in a proper namespace until they may be 170destructuring. LIST, RESULT and BODY are as for `cl-dolist'.
155;; used from there. 171Note that definitions in ARGLIST are visible only in the BODY and
156 172neither in RESULT nor in LIST."
157(defun rst-signum (x) 173 ;; FIXME: It would be very useful if the definitions in ARGLIST would be
174 ;; visible in RESULT. But may be this is rather a
175 ;; `rst-destructuring-do' then.
176 (declare (debug
177 (&define ([&or symbolp cl-macro-list] def-form &optional def-form)
178 cl-declarations def-body))
179 (indent 1))
180 (let ((var (make-symbol "--rst-destructuring-dolist-var--")))
181 `(cl-dolist (,var ,list ,result)
182 (cl-destructuring-bind ,arglist ,var
183 ,@body))))
184
185(defun rst-forward-line-strict (n &optional limit)
158 ;; testcover: ok. 186 ;; testcover: ok.
159 "Return 1 if X is positive, -1 if negative, 0 if zero." 187 "Try to move point to beginning of line I + N where I is the current line.
160 (cond 188Return t if movement is successful. Otherwise don't move point
161 ((> x 0) 1) 189and return nil. If a position is given by LIMIT, movement
162 ((< x 0) -1) 190happened but the following line is missing and thus its beginning
163 (t 0))) 191can not be reached but the movement reached at least LIMIT
164 192consider this a successful movement. LIMIT is ignored in other
165(defun rst-some (seq &optional pred) 193cases."
166 ;; testcover: ok. 194 (let ((start (point)))
167 "Return non-nil if any element of SEQ yields non-nil when PRED is applied. 195 (if (and (zerop (forward-line n))
168Apply PRED to each element of list SEQ until the first non-nil 196 (or (bolp)
169result is yielded and return this result. PRED defaults to 197 (and limit
170`identity'." 198 (>= (point) limit))))
171 (unless pred 199 t
172 (setq pred 'identity)) 200 (goto-char start)
173 (catch 'rst-some 201 nil)))
174 (dolist (elem seq) 202
175 (let ((r (funcall pred elem))) 203(defun rst-forward-line-looking-at (n rst-re-args &optional fun)
176 (when r
177 (throw 'rst-some r))))))
178
179(defun rst-position-if (pred seq)
180 ;; testcover: ok.
181 "Return position of first element satisfying PRED in list SEQ or nil."
182 (catch 'rst-position-if
183 (let ((i 0))
184 (dolist (elem seq)
185 (when (funcall pred elem)
186 (throw 'rst-position-if i))
187 (incf i)))))
188
189(defun rst-position (elem seq)
190 ;; testcover: ok. 204 ;; testcover: ok.
191 "Return position of ELEM in list SEQ or nil. 205 "Move forward N lines and if successful check whether RST-RE-ARGS is matched.
192Comparison done with `equal'." 206Moving forward is done by `rst-forward-line-strict'. RST-RE-ARGS
193 ;; Create a closure containing `elem' so the `lambda' always sees our 207is a single or a list of arguments for `rst-re'. FUN is a
194 ;; parameter instead of an `elem' which may be in dynamic scope at the time 208function defaulting to `identity' which is called after the call
195 ;; of execution of the `lambda'. 209to `looking-at' receiving its return value as the first argument.
196 (lexical-let ((elem elem)) 210When FUN is called match data is just set by `looking-at' and
197 (rst-position-if (function (lambda (e) 211point is at the beginning of the line. Return nil if moving
198 (equal elem e))) 212forward failed or otherwise the return value of FUN. Preserve
199 seq))) 213global match data, point, mark and current buffer."
200 214 (unless (listp rst-re-args)
201(defun rst-member-if (pred seq) 215 (setq rst-re-args (list rst-re-args)))
202 ;; testcover: ok. 216 (unless fun
203 "Return sublist of SEQ starting with the element whose car satisfies PRED." 217 (setq fun #'identity))
204 (let (found) 218 (save-match-data
205 (while (and (not found) seq) 219 (save-excursion
206 (if (funcall pred (car seq)) 220 (when (rst-forward-line-strict n)
207 (setq found seq) 221 (funcall fun (looking-at (apply #'rst-re rst-re-args)))))))
208 (setq seq (cdr seq)))) 222
209 found)) 223(rst-testcover-add-1value 'rst-delete-entire-line)
224(defun rst-delete-entire-line (n)
225 "Move N lines and delete the entire line."
226 (delete-region (line-beginning-position (+ n 1))
227 (line-beginning-position (+ n 2))))
210 228
211 229
212;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 230;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -226,7 +244,7 @@ and before TAIL-RE and DELIM-RE in VAR or DEFAULT for no match."
226;; Use CVSHeader to really get information from CVS and not other version 244;; Use CVSHeader to really get information from CVS and not other version
227;; control systems. 245;; control systems.
228(defconst rst-cvs-header 246(defconst rst-cvs-header
229 "$CVSHeader: sm/rst_el/rst.el,v 1.600 2016/07/31 11:13:44 stefan Exp $") 247 "$CVSHeader: sm/rst_el/rst.el,v 1.1058.2.3 2017/01/03 21:56:29 stefan Exp $")
230(defconst rst-cvs-rev 248(defconst rst-cvs-rev
231 (rst-extract-version "\\$" "CVSHeader: \\S + " "[0-9]+\\(?:\\.[0-9]+\\)+" 249 (rst-extract-version "\\$" "CVSHeader: \\S + " "[0-9]+\\(?:\\.[0-9]+\\)+"
232 " .*" rst-cvs-header "0.0") 250 " .*" rst-cvs-header "0.0")
@@ -240,22 +258,22 @@ and before TAIL-RE and DELIM-RE in VAR or DEFAULT for no match."
240;; Use LastChanged... to really get information from SVN. 258;; Use LastChanged... to really get information from SVN.
241(defconst rst-svn-rev 259(defconst rst-svn-rev
242 (rst-extract-version "\\$" "LastChangedRevision: " "[0-9]+" " " 260 (rst-extract-version "\\$" "LastChangedRevision: " "[0-9]+" " "
243 "$LastChangedRevision: 7963 $") 261 "$LastChangedRevision: 8011 $")
244 "The SVN revision of this file. 262 "The SVN revision of this file.
245SVN revision is the upstream (docutils) revision.") 263SVN revision is the upstream (docutils) revision.")
246(defconst rst-svn-timestamp 264(defconst rst-svn-timestamp
247 (rst-extract-version "\\$" "LastChangedDate: " ".+?+" " " 265 (rst-extract-version "\\$" "LastChangedDate: " ".+?+" " "
248 "$LastChangedDate: 2016-07-31 13:13:21 +0200 (Sun, 31 Jul 2016) $") 266 "$LastChangedDate: 2017-01-03 22:56:17 +0100 (Tue, 03 Jan 2017) $")
249 "The SVN time stamp of this file.") 267 "The SVN time stamp of this file.")
250 268
251;; Maintained by the release process. 269;; Maintained by the release process.
252(defconst rst-official-version 270(defconst rst-official-version
253 (rst-extract-version "%" "OfficialVersion: " "[0-9]+\\(?:\\.[0-9]+\\)+" " " 271 (rst-extract-version "%" "OfficialVersion: " "[0-9]+\\(?:\\.[0-9]+\\)+" " "
254 "%OfficialVersion: 1.5.0 %") 272 "%OfficialVersion: 1.5.1 %")
255 "Official version of the package.") 273 "Official version of the package.")
256(defconst rst-official-cvs-rev 274(defconst rst-official-cvs-rev
257 (rst-extract-version "[%$]" "Revision: " "[0-9]+\\(?:\\.[0-9]+\\)+" " " 275 (rst-extract-version "[%$]" "Revision: " "[0-9]+\\(?:\\.[0-9]+\\)+" " "
258 "%Revision: 1.600 %") 276 "$Revision: 1.1058.2.3 $")
259 "CVS revision of this file in the official version.") 277 "CVS revision of this file in the official version.")
260 278
261(defconst rst-version 279(defconst rst-version
@@ -278,6 +296,7 @@ in parentheses follows the development revision and the time stamp.")
278 ("1.4.1" . "24.5") 296 ("1.4.1" . "24.5")
279 ("1.4.2" . "24.5") 297 ("1.4.2" . "24.5")
280 ("1.5.0" . "26.1") 298 ("1.5.0" . "26.1")
299 ("1.5.1" . "26.2")
281 )) 300 ))
282 301
283(unless (assoc rst-official-version rst-package-emacs-version-alist) 302(unless (assoc rst-official-version rst-package-emacs-version-alist)
@@ -368,6 +387,7 @@ in parentheses follows the development revision and the time stamp.")
368 387
369 ;; Various starts 388 ;; Various starts
370 (bul-sta bul-tag bli-sfx) ; Start of a bulleted item. 389 (bul-sta bul-tag bli-sfx) ; Start of a bulleted item.
390 (bul-beg lin-beg bul-sta) ; A bullet item at the beginning of a line.
371 391
372 ;; Explicit markup tag (`exm') 392 ;; Explicit markup tag (`exm')
373 (exm-tag "\\.\\.") 393 (exm-tag "\\.\\.")
@@ -571,34 +591,34 @@ referenceable group (\"\\(...\\)\").
571 591
572After interpretation of ARGS the results are concatenated as for 592After interpretation of ARGS the results are concatenated as for
573`:seq'." 593`:seq'."
574 (apply 'concat 594 (apply #'concat
575 (mapcar 595 (mapcar
576 (lambda (re) 596 #'(lambda (re)
577 (cond 597 (cond
578 ((stringp re) 598 ((stringp re)
579 re) 599 re)
580 ((symbolp re) 600 ((symbolp re)
581 (cadr (assoc re rst-re-alist))) 601 (cadr (assoc re rst-re-alist)))
582 ((characterp re) 602 ((characterp re)
583 (regexp-quote (char-to-string re))) 603 (regexp-quote (char-to-string re)))
584 ((listp re) 604 ((listp re)
585 (let ((nested 605 (let ((nested
586 (mapcar (lambda (elt) 606 (mapcar (lambda (elt)
587 (rst-re elt)) 607 (rst-re elt))
588 (cdr re)))) 608 (cdr re))))
589 (cond 609 (cond
590 ((eq (car re) :seq) 610 ((eq (car re) :seq)
591 (mapconcat 'identity nested "")) 611 (mapconcat #'identity nested ""))
592 ((eq (car re) :shy) 612 ((eq (car re) :shy)
593 (concat "\\(?:" (mapconcat 'identity nested "") "\\)")) 613 (concat "\\(?:" (mapconcat #'identity nested "") "\\)"))
594 ((eq (car re) :grp) 614 ((eq (car re) :grp)
595 (concat "\\(" (mapconcat 'identity nested "") "\\)")) 615 (concat "\\(" (mapconcat #'identity nested "") "\\)"))
596 ((eq (car re) :alt) 616 ((eq (car re) :alt)
597 (concat "\\(?:" (mapconcat 'identity nested "\\|") "\\)")) 617 (concat "\\(?:" (mapconcat #'identity nested "\\|") "\\)"))
598 (t 618 (t
599 (error "Unknown list car: %s" (car re)))))) 619 (error "Unknown list car: %s" (car re))))))
600 (t 620 (t
601 (error "Unknown object type for building regex: %s" re)))) 621 (error "Unknown object type for building regex: %s" re))))
602 args))) 622 args)))
603 623
604;; FIXME: Remove circular dependency between `rst-re' and `rst-re-alist'. 624;; FIXME: Remove circular dependency between `rst-re' and `rst-re-alist'.
@@ -610,7 +630,7 @@ After interpretation of ARGS the results are concatenated as for
610 (dolist (re rst-re-alist-def rst-re-alist) 630 (dolist (re rst-re-alist-def rst-re-alist)
611 (setq rst-re-alist 631 (setq rst-re-alist
612 (nconc rst-re-alist 632 (nconc rst-re-alist
613 (list (list (car re) (apply 'rst-re (cdr re)))))))) 633 (list (list (car re) (apply #'rst-re (cdr re))))))))
614 "Alist mapping symbols from `rst-re-alist-def' to regex strings.")) 634 "Alist mapping symbols from `rst-re-alist-def' to regex strings."))
615 635
616 636
@@ -630,9 +650,9 @@ After interpretation of ARGS the results are concatenated as for
630;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 650;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
631;; Class rst-Ado 651;; Class rst-Ado
632 652
633(defstruct 653(cl-defstruct
634 (rst-Ado 654 (rst-Ado
635 (:constructor nil) ;; Prevent creating unchecked values. 655 (:constructor nil) ; Prevent creating unchecked values.
636 ;; Construct a transition. 656 ;; Construct a transition.
637 (:constructor 657 (:constructor
638 rst-Ado-new-transition 658 rst-Ado-new-transition
@@ -682,61 +702,45 @@ This type is immutable."
682 ;; testcover: ok. 702 ;; testcover: ok.
683 "Validate CHAR to be a valid adornment character. 703 "Validate CHAR to be a valid adornment character.
684Return CHAR if so or signal an error otherwise." 704Return CHAR if so or signal an error otherwise."
685 (cond 705 (cl-check-type char character)
686 ((not (characterp char)) 706 (cl-check-type char (satisfies
687 (signal 'wrong-type-argument (list 'characterp char))) 707 (lambda (c)
688 ((memq char rst-adornment-chars) 708 (memq c rst-adornment-chars)))
689 char) 709 "Character must be a valid adornment character")
690 (t 710 char)
691 (signal 'args-out-of-range
692 (list (format
693 "Character must be a valid adornment character, not '%s'"
694 char))))))
695 711
696;; Public methods 712;; Public methods
697 713
698(defun rst-Ado-is-transition (self) 714(defun rst-Ado-is-transition (self)
699 ;; testcover: ok. 715 ;; testcover: ok.
700 "Return non-nil if SELF is a transition adornment." 716 "Return non-nil if SELF is a transition adornment."
701 (unless (rst-Ado-p self) 717 (cl-check-type self rst-Ado)
702 (signal 'wrong-type-argument
703 (list 'rst-Ado-p self)))
704 (eq (rst-Ado--style self) 'transition)) 718 (eq (rst-Ado--style self) 'transition))
705 719
706(defun rst-Ado-is-section (self) 720(defun rst-Ado-is-section (self)
707 ;; testcover: ok. 721 ;; testcover: ok.
708 "Return non-nil if SELF is a section adornment." 722 "Return non-nil if SELF is a section adornment."
709 (unless (rst-Ado-p self) 723 (cl-check-type self rst-Ado)
710 (signal 'wrong-type-argument
711 (list 'rst-Ado-p self)))
712 (not (rst-Ado-is-transition self))) 724 (not (rst-Ado-is-transition self)))
713 725
714(defun rst-Ado-is-simple (self) 726(defun rst-Ado-is-simple (self)
715 ;; testcover: ok. 727 ;; testcover: ok.
716 "Return non-nil if SELF is a simple section adornment." 728 "Return non-nil if SELF is a simple section adornment."
717 (unless (rst-Ado-p self) 729 (cl-check-type self rst-Ado)
718 (signal 'wrong-type-argument
719 (list 'rst-Ado-p self)))
720 (eq (rst-Ado--style self) 'simple)) 730 (eq (rst-Ado--style self) 'simple))
721 731
722(defun rst-Ado-is-over-and-under (self) 732(defun rst-Ado-is-over-and-under (self)
723 ;; testcover: ok. 733 ;; testcover: ok.
724 "Return non-nil if SELF is a over-and-under section adornment." 734 "Return non-nil if SELF is a over-and-under section adornment."
725 (unless (rst-Ado-p self) 735 (cl-check-type self rst-Ado)
726 (signal 'wrong-type-argument
727 (list 'rst-Ado-p self)))
728 (eq (rst-Ado--style self) 'over-and-under)) 736 (eq (rst-Ado--style self) 'over-and-under))
729 737
730(defun rst-Ado-equal (self other) 738(defun rst-Ado-equal (self other)
731 ;; testcover: ok. 739 ;; testcover: ok.
732 "Return non-nil when SELF and OTHER are equal." 740 "Return non-nil when SELF and OTHER are equal."
741 (cl-check-type self rst-Ado)
742 (cl-check-type other rst-Ado)
733 (cond 743 (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))) 744 ((not (eq (rst-Ado--style self) (rst-Ado--style other)))
741 nil) 745 nil)
742 ((rst-Ado-is-transition self)) 746 ((rst-Ado-is-transition self))
@@ -744,22 +748,19 @@ Return CHAR if so or signal an error otherwise."
744 748
745(defun rst-Ado-position (self ados) 749(defun rst-Ado-position (self ados)
746 ;; testcover: ok. 750 ;; testcover: ok.
747 "Return position of of SELF in ADOS or nil." 751 "Return position of SELF in ADOS or nil."
748 (unless (rst-Ado-p self) 752 (cl-check-type self rst-Ado)
749 (signal 'wrong-type-argument 753 (cl-position-if #'(lambda (e)
750 (list 'rst-Ado-p self))) 754 (rst-Ado-equal self e))
751 (lexical-let ((ado self)) ;; Create closure. 755 ados))
752 (rst-position-if (function (lambda (e)
753 (rst-Ado-equal ado e)))
754 ados)))
755 756
756 757
757;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 758;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
758;; Class rst-Hdr 759;; Class rst-Hdr
759 760
760(defstruct 761(cl-defstruct
761 (rst-Hdr 762 (rst-Hdr
762 (:constructor nil) ;; Prevent creating unchecked values. 763 (:constructor nil) ; Prevent creating unchecked values.
763 ;; Construct while all parameters must be valid. 764 ;; Construct while all parameters must be valid.
764 (:constructor 765 (:constructor
765 rst-Hdr-new 766 rst-Hdr-new
@@ -784,7 +785,7 @@ Return CHAR if so or signal an error otherwise."
784 &aux 785 &aux
785 (ado (rst-Hdr--validate-ado (rst-Ado-new-invert ado-arg))) 786 (ado (rst-Hdr--validate-ado (rst-Ado-new-invert ado-arg)))
786 (indent (rst-Hdr--validate-indent indent-arg ado t)))) 787 (indent (rst-Hdr--validate-indent indent-arg ado t))))
787 (:copier rst-Hdr-copy)) ;; Not really needed for an immutable type. 788 (:copier nil)) ; Not really needed for an immutable type.
788 "Representation of reStructuredText section header characteristics. 789 "Representation of reStructuredText section header characteristics.
789 790
790This type is immutable." 791This type is immutable."
@@ -800,10 +801,8 @@ This type is immutable."
800 "Validate INDENT to be a valid indentation for ADO. 801 "Validate INDENT to be a valid indentation for ADO.
801Return INDENT if so or signal an error otherwise. If LAX don't 802Return INDENT if so or signal an error otherwise. If LAX don't
802signal an error and return a valid indent." 803signal an error and return a valid indent."
804 (cl-check-type indent integer)
803 (cond 805 (cond
804 ((not (integerp indent))
805 (signal 'wrong-type-argument
806 (list 'integerp 'null indent)))
807 ((zerop indent) 806 ((zerop indent)
808 indent) 807 indent)
809 ((rst-Ado-is-simple ado) 808 ((rst-Ado-is-simple ado)
@@ -816,33 +815,34 @@ signal an error and return a valid indent."
816 0 815 0
817 (signal 'args-out-of-range 816 (signal 'args-out-of-range
818 '("Indentation must not be negative")))) 817 '("Indentation must not be negative"))))
819 (indent))) ;; Implicitly over-and-under. 818 ;; Implicitly over-and-under.
819 (indent)))
820 820
821(defun rst-Hdr--validate-ado (ado) 821(defun rst-Hdr--validate-ado (ado)
822 ;; testcover: ok. 822 ;; testcover: ok.
823 "Validate ADO to be a valid adornment. 823 "Validate ADO to be a valid adornment.
824Return ADO if so or signal an error otherwise." 824Return ADO if so or signal an error otherwise."
825 (cl-check-type ado rst-Ado)
825 (cond 826 (cond
826 ((not (rst-Ado-p ado))
827 (signal 'wrong-type-argument
828 (list 'rst-Ado-p ado)))
829 ((rst-Ado-is-transition ado) 827 ((rst-Ado-is-transition ado)
830 (signal 'args-out-of-range 828 (signal 'args-out-of-range
831 '("Adornment for header must not be transition."))) 829 '("Adornment for header must not be transition.")))
832 (t 830 (ado)))
833 ado)))
834 831
835;; Public class methods 832;; Public class methods
836 833
834(defvar rst-preferred-adornments) ; Forward declaration.
835
837(defun rst-Hdr-preferred-adornments () 836(defun rst-Hdr-preferred-adornments ()
838 ;; testcover: ok. 837 ;; testcover: ok.
839 "Return preferred adornments as list of `rst-Hdr'." 838 "Return preferred adornments as list of `rst-Hdr'."
840 (mapcar (lambda (el) 839 (mapcar (cl-function
841 (rst-Hdr-new-lax 840 (lambda ((character style indent))
842 (if (eq (cadr el) 'over-and-under) 841 (rst-Hdr-new-lax
843 (rst-Ado-new-over-and-under (car el)) 842 (if (eq style 'over-and-under)
844 (rst-Ado-new-simple (car el))) 843 (rst-Ado-new-over-and-under character)
845 (caddr el))) 844 (rst-Ado-new-simple character))
845 indent)))
846 rst-preferred-adornments)) 846 rst-preferred-adornments))
847 847
848;; Public methods 848;; Public methods
@@ -850,238 +850,238 @@ Return ADO if so or signal an error otherwise."
850(defun rst-Hdr-member-ado (self hdrs) 850(defun rst-Hdr-member-ado (self hdrs)
851 ;; testcover: ok. 851 ;; testcover: ok.
852 "Return sublist of HDRS whose car's adornment equals that of SELF or nil." 852 "Return sublist of HDRS whose car's adornment equals that of SELF or nil."
853 (unless (rst-Hdr-p self) 853 (cl-check-type self rst-Hdr)
854 (signal 'wrong-type-argument 854 (let ((ado (rst-Hdr-ado self)))
855 (list 'rst-Hdr-p self))) 855 (cl-member-if #'(lambda (hdr)
856 (let ((pos (rst-Ado-position (rst-Hdr-ado self) (rst-Hdr-ado-map hdrs)))) 856 (rst-Ado-equal ado (rst-Hdr-ado hdr)))
857 (and pos (nthcdr pos hdrs)))) 857 hdrs)))
858 858
859(defun rst-Hdr-ado-map (selves) 859(defun rst-Hdr-ado-map (selves)
860 ;; testcover: ok. 860 ;; testcover: ok.
861 "Return `rst-Ado' list extracted from elements of SELVES." 861 "Return `rst-Ado' list extracted from elements of SELVES."
862 (mapcar 'rst-Hdr-ado selves)) 862 (mapcar #'rst-Hdr-ado selves))
863 863
864(defun rst-Hdr-get-char (self) 864(defun rst-Hdr-get-char (self)
865 ;; testcover: ok. 865 ;; testcover: ok.
866 "Return character of the adornment of SELF." 866 "Return character of the adornment of SELF."
867 (unless (rst-Hdr-p self) 867 (cl-check-type self rst-Hdr)
868 (signal 'wrong-type-argument
869 (list 'rst-Hdr-p self)))
870 (rst-Ado-char (rst-Hdr-ado self))) 868 (rst-Ado-char (rst-Hdr-ado self)))
871 869
872(defun rst-Hdr-is-over-and-under (self) 870(defun rst-Hdr-is-over-and-under (self)
873 ;; testcover: ok. 871 ;; testcover: ok.
874 "Return non-nil if SELF is a over-and-under section header." 872 "Return non-nil if SELF is a over-and-under section header."
875 (unless (rst-Hdr-p self) 873 (cl-check-type self rst-Hdr)
876 (signal 'wrong-type-argument
877 (list 'rst-Hdr-p self)))
878 (rst-Ado-is-over-and-under (rst-Hdr-ado self))) 874 (rst-Ado-is-over-and-under (rst-Hdr-ado self)))
879 875
880 876
881;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 877;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
882;; Class rst-Ttl 878;; Class rst-Ttl
883 879
884(defstruct 880(cl-defstruct
885 (rst-Ttl 881 (rst-Ttl
886 (:constructor nil) ;; Prevent creating unchecked values. 882 (:constructor nil) ; Prevent creating unchecked values.
887 ;; Construct with valid parameters for all attributes. 883 ;; Construct with valid parameters for all attributes.
888 (:constructor 884 (:constructor ; Private constructor
889 rst-Ttl-new 885 rst-Ttl--new
890 (ado-arg 886 (ado-arg
891 match-arg 887 match-arg
892 indent-arg 888 indent-arg
893 text-arg 889 text-arg
894 &optional
895 hdr-arg
896 level-arg
897 &aux 890 &aux
898 (ado (rst-Ttl--validate-ado ado-arg)) 891 (ado (rst-Ttl--validate-ado ado-arg))
899 (match (rst-Ttl--validate-match match-arg ado)) 892 (match (rst-Ttl--validate-match match-arg ado))
900 (indent (rst-Ttl--validate-indent indent-arg ado)) 893 (indent (rst-Ttl--validate-indent indent-arg ado))
901 (text (rst-Ttl--validate-text text-arg ado)) 894 (text (rst-Ttl--validate-text text-arg ado))
902 (hdr (and hdr-arg (rst-Ttl--validate-hdr hdr-arg ado indent))) 895 (hdr (condition-case nil
903 (level (and level-arg (rst-Ttl--validate-level level-arg))))) 896 (rst-Hdr-new ado indent)
904 (:copier rst-Ttl-copy)) 897 (error nil)))))
905 "Representation of a reStructuredText section header as found in the buffer. 898 (:copier nil)) ; Not really needed for an immutable type.
906This type gathers information about an adorned part in the 899 "Representation of a reStructuredText section header as found in a buffer.
907buffer. Thus only the basic attributes are immutable. Although 900This type gathers information about an adorned part in the buffer.
908the remaining attributes are `setf'-able the respective setters 901
909should be used." 902This type is immutable."
910 ;; The adornment characteristics or nil for a title candidate. 903 ;; The adornment characteristics or nil for a title candidate.
911 (ado nil :read-only t) 904 (ado nil :read-only t)
912 ;; The match-data for `ado' as returned by `match-data'. Match group 0 905 ;; The match-data for `ado' in a form similarly returned by `match-data' (but
913 ;; matches the whole construct. Match group 1 matches the overline adornment 906 ;; not necessarily with markers in buffers). Match group 0 matches the whole
914 ;; if present. Match group 2 matches the section title text or the 907 ;; construct. Match group 1 matches the overline adornment if present.
915 ;; transition. Match group 3 matches the underline adornment. 908 ;; Match group 2 matches the section title text or the transition. Match
909 ;; group 3 matches the underline adornment.
916 (match nil :read-only t) 910 (match nil :read-only t)
917 ;; An indentation found for the title line or nil for a transition. 911 ;; An indentation found for the title line or nil for a transition.
918 (indent nil :read-only t) 912 (indent nil :read-only t)
919 ;; The text of the title or nil for a transition. 913 ;; The text of the title or nil for a transition.
920 (text nil :read-only t) 914 (text nil :read-only t)
921 ;; The header characteristics if it is a valid section header. 915 ;; The header characteristics if it is a valid section header.
922 (hdr nil) 916 (hdr nil :read-only t)
923 ;; The hierarchical level of the section header starting with 0. 917 ;; FIXME refactoring: Should have an attribute `buffer' for the buffer this
924 (level nil)) 918 ;; title is found in. This breaks lots and lots of tests.
919 ;; However, with private constructor they may not be
920 ;; necessary any more. In case it is really a buffer then
921 ;; also `match' could be real data from `match-data' which
922 ;; contains markers instead of integers.
923 )
925 924
926;; Private class methods 925;; Private class methods
927 926
928(defun rst-Ttl--validate-ado (ado) 927(defun rst-Ttl--validate-ado (ado)
929 ;; testcover: ok. 928 ;; testcover: ok.
930 "Return valid ADO or signal error." 929 "Return valid ADO or signal error."
931 (unless (or (null ado) (rst-Ado-p ado)) 930 (cl-check-type ado (or null rst-Ado))
932 (signal 'wrong-type-argument
933 (list 'null 'rst-Ado-p ado)))
934 ado) 931 ado)
935 932
936(defun rst-Ttl--validate-match (match ado) 933(defun rst-Ttl--validate-match (match ado)
937 ;; testcover: ok. 934 ;; testcover: ok.
938 "Return valid MATCH matching ADO or signal error." 935 "Return valid MATCH matching ADO or signal error."
939 (unless (listp match) 936 (cl-check-type ado (or null rst-Ado))
940 (signal 'wrong-type-argument 937 (cl-check-type match list)
941 (list 'listp match))) 938 (cl-check-type match (satisfies (lambda (m)
942 (unless (equal (length match) 8) 939 (equal (length m) 8)))
943 (signal 'args-out-of-range 940 "Match data must consist of exactly 8 buffer positions.")
944 '("Match data must consist of exactly 8 buffer positions."))) 941 (dolist (pos match)
945 (mapcar (lambda (pos) 942 (cl-check-type pos (or null integer-or-marker)))
946 (unless (or (null pos) (integer-or-marker-p pos)) 943 (cl-destructuring-bind (all-beg all-end
947 (signal 'wrong-type-argument 944 ovr-beg ovr-end
948 (list 'integer-or-marker-p 'null pos)))) 945 txt-beg txt-end
949 match) 946 und-beg und-end) match
950 (unless (and (integer-or-marker-p (nth 0 match)) 947 (unless (and (integer-or-marker-p all-beg) (integer-or-marker-p all-end))
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 948 (signal 'args-out-of-range
972 '("For a transition exactly the third match pair must be set.")))) 949 '("First two elements of match data must be buffer positions.")))
973 ((rst-Ado-is-simple ado) 950 (cond
974 (unless (and (null (nth 2 match)) 951 ((null ado)
975 (null (nth 3 match)) 952 (unless (and (null ovr-beg) (null ovr-end)
976 (integer-or-marker-p (nth 4 match)) 953 (integer-or-marker-p txt-beg) (integer-or-marker-p txt-end)
977 (integer-or-marker-p (nth 5 match)) 954 (null und-beg) (null und-end))
978 (integer-or-marker-p (nth 6 match)) 955 (signal 'args-out-of-range
979 (integer-or-marker-p (nth 7 match))) 956 '("For a title candidate exactly the third match pair must be set."))))
980 (signal 'args-out-of-range 957 ((rst-Ado-is-transition ado)
981 '("For a simple section adornment exactly the third and fourth match pair must be set.")))) 958 (unless (and (null ovr-beg) (null ovr-end)
982 (t ;; over-and-under 959 (integer-or-marker-p txt-beg) (integer-or-marker-p txt-end)
983 (unless (and (integer-or-marker-p (nth 2 match)) 960 (null und-beg) (null und-end))
984 (integer-or-marker-p (nth 3 match)) 961 (signal 'args-out-of-range
985 (integer-or-marker-p (nth 4 match)) 962 '("For a transition exactly the third match pair must be set."))))
986 (integer-or-marker-p (nth 5 match)) 963 ((rst-Ado-is-simple ado)
987 (or (null (nth 6 match)) (integer-or-marker-p (nth 6 match))) 964 (unless (and (null ovr-beg) (null ovr-end)
988 (or (null (nth 7 match)) (integer-or-marker-p (nth 7 match)))) 965 (integer-or-marker-p txt-beg) (integer-or-marker-p txt-end)
989 (signal 'args-out-of-range 966 (integer-or-marker-p und-beg) (integer-or-marker-p und-end))
990 '("For a over-and-under section adornment all match pairs must be set."))))) 967 (signal 'args-out-of-range
968 '("For a simple section adornment exactly the third and fourth match pair must be set."))))
969 (t ; over-and-under
970 (unless (and (integer-or-marker-p ovr-beg) (integer-or-marker-p ovr-end)
971 (integer-or-marker-p txt-beg) (integer-or-marker-p txt-end)
972 (or (null und-beg) (integer-or-marker-p und-beg))
973 (or (null und-end) (integer-or-marker-p und-end)))
974 (signal 'args-out-of-range
975 '("For a over-and-under section adornment all match pairs must be set."))))))
991 match) 976 match)
992 977
993(defun rst-Ttl--validate-indent (indent ado) 978(defun rst-Ttl--validate-indent (indent ado)
994 ;; testcover: ok. 979 ;; testcover: ok.
995 "Return valid INDENT for ADO or signal error." 980 "Return valid INDENT for ADO or signal error."
996 (if (and ado (rst-Ado-is-transition ado)) 981 (if (and ado (rst-Ado-is-transition ado))
997 (unless (null indent) 982 (cl-check-type indent null
998 (signal 'args-out-of-range 983 "Indent for a transition must be nil.")
999 '("Indent for a transition must be nil."))) 984 (cl-check-type indent (integer 0 *)
1000 (unless (integerp indent) 985 "Indent for a section header must be non-negative."))
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) 986 indent)
1007 987
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) 988(defun rst-Ttl--validate-text (text ado)
1023 ;; testcover: ok. 989 ;; testcover: ok.
1024 "Return valid TEXT for ADO or signal error." 990 "Return valid TEXT for ADO or signal error."
1025 (if (and ado (rst-Ado-is-transition ado)) 991 (if (and ado (rst-Ado-is-transition ado))
1026 (unless (null text) 992 (cl-check-type text null
1027 (signal 'args-out-of-range 993 "Transitions may not have title text.")
1028 '("Transitions may not have title text."))) 994 (cl-check-type text string))
1029 (unless (stringp text)
1030 (signal 'wrong-type-argument
1031 (list 'stringp text))))
1032 text) 995 text)
1033 996
1034(defun rst-Ttl--validate-level (level) 997;; Public class methods
998
999(defun rst-Ttl-from-buffer (ado beg-ovr beg-txt beg-und txt)
1035 ;; testcover: ok. 1000 ;; testcover: ok.
1036 "Return valid LEVEL or signal error." 1001 "Return a `rst-Ttl' constructed from information in the current buffer.
1037 (unless (integerp level) 1002ADO is the adornment or nil for a title candidate. BEG-OVR and
1038 (signal 'wrong-type-argument 1003BEG-UND are the starting points of the overline or underline,
1039 (list 'integerp level))) 1004respectively. They may be nil if the respective thing is missing.
1040 (unless (>= level 0) 1005BEG-TXT is the beginning of the title line or the transition and
1041 (signal 'args-out-of-range 1006must be given. The end of the line is used as the end point. TXT
1042 '("Level must be non-negative."))) 1007is the title text or nil. If TXT is given the indendation of the
1043 level) 1008line containing BEG-TXT is used as indentation. Match group 0 is
1009derived from the remaining information."
1010 (cl-check-type beg-txt integer-or-marker)
1011 (save-excursion
1012 (let ((end-ovr (when beg-ovr
1013 (goto-char beg-ovr)
1014 (line-end-position)))
1015 (end-txt (progn
1016 (goto-char beg-txt)
1017 (line-end-position)))
1018 (end-und (when beg-und
1019 (goto-char beg-und)
1020 (line-end-position)))
1021 (ind (when txt
1022 (goto-char beg-txt)
1023 (current-indentation))))
1024 (rst-Ttl--new ado
1025 (list
1026 (or beg-ovr beg-txt) (or end-und end-txt)
1027 beg-ovr end-ovr
1028 beg-txt end-txt
1029 beg-und end-und)
1030 ind txt))))
1044 1031
1045;; Public methods 1032;; Public methods
1046 1033
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) 1034(defun rst-Ttl-get-title-beginning (self)
1063 ;; testcover: ok. 1035 ;; testcover: ok.
1064 "Return position of beginning of title text of SELF. 1036 "Return position of beginning of title text of SELF.
1065This position should always be at the start of a line." 1037This position should always be at the start of a line."
1038 (cl-check-type self rst-Ttl)
1066 (nth 4 (rst-Ttl-match self))) 1039 (nth 4 (rst-Ttl-match self)))
1067 1040
1068(defun rst-Ttl-get-beginning (self) 1041(defun rst-Ttl-get-beginning (self)
1069 ;; testcover: ok. 1042 ;; testcover: ok.
1070 "Return position of beginning of whole SELF." 1043 "Return position of beginning of whole SELF."
1044 (cl-check-type self rst-Ttl)
1071 (nth 0 (rst-Ttl-match self))) 1045 (nth 0 (rst-Ttl-match self)))
1072 1046
1073(defun rst-Ttl-get-end (self) 1047(defun rst-Ttl-get-end (self)
1074 ;; testcover: ok. 1048 ;; testcover: ok.
1075 "Return position of end of whole SELF." 1049 "Return position of end of whole SELF."
1050 (cl-check-type self rst-Ttl)
1076 (nth 1 (rst-Ttl-match self))) 1051 (nth 1 (rst-Ttl-match self)))
1077 1052
1053(defun rst-Ttl-is-section (self)
1054 ;; testcover: ok.
1055 "Return non-nil if SELF is a section header or candidate."
1056 (cl-check-type self rst-Ttl)
1057 (rst-Ttl-text self))
1058
1059(defun rst-Ttl-is-candidate (self)
1060 ;; testcover: ok.
1061 "Return non-nil if SELF is a candidate for a section header."
1062 (cl-check-type self rst-Ttl)
1063 (not (rst-Ttl-ado self)))
1064
1065(defun rst-Ttl-contains (self position)
1066 "Return whether SELF contain POSITION.
1067Return 0 if SELF contains POSITION, < 0 if SELF ends before
1068POSITION and > 0 if SELF starts after position."
1069 (cl-check-type self rst-Ttl)
1070 (cl-check-type position integer-or-marker)
1071 (cond
1072 ((< (nth 1 (rst-Ttl-match self)) position)
1073 -1)
1074 ((> (nth 0 (rst-Ttl-match self)) position)
1075 +1)
1076 (0)))
1077
1078 1078
1079;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1079;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1080;; Class rst-Stn 1080;; Class rst-Stn
1081 1081
1082(defstruct 1082(cl-defstruct
1083 (rst-Stn 1083 (rst-Stn
1084 (:constructor nil) ;; Prevent creating unchecked values. 1084 (:constructor nil) ; Prevent creating unchecked values.
1085 ;; Construct while all parameters must be valid. 1085 ;; Construct while all parameters must be valid.
1086 (:constructor 1086 (:constructor
1087 rst-Stn-new 1087 rst-Stn-new
@@ -1102,45 +1102,33 @@ This type is immutable."
1102 (level nil :read-only t) 1102 (level nil :read-only t)
1103 ;; The list of children of the node. 1103 ;; The list of children of the node.
1104 (children nil :read-only t)) 1104 (children nil :read-only t))
1105;; FIXME refactoring: Should have an attribute `buffer' for the buffer this
1106;; title is found in. Or use `rst-Ttl-buffer'.
1105 1107
1106;; Private class methods 1108;; Private class methods
1107 1109
1108(defun rst-Stn--validate-ttl (ttl) 1110(defun rst-Stn--validate-ttl (ttl)
1109 ;; testcover: ok. 1111 ;; testcover: ok.
1110 "Return valid TTL or signal error." 1112 "Return valid TTL or signal error."
1111 (unless (or (null ttl) (rst-Ttl-p ttl)) 1113 (cl-check-type ttl (or null rst-Ttl))
1112 (signal 'wrong-type-argument
1113 (list 'null 'rst-Ttl-p ttl)))
1114 ttl) 1114 ttl)
1115 1115
1116(defun rst-Stn--validate-level (level ttl) 1116(defun rst-Stn--validate-level (level ttl)
1117 ;; testcover: ok. 1117 ;; testcover: ok.
1118 "Return valid LEVEL for TTL or signal error." 1118 "Return valid LEVEL for TTL or signal error."
1119 (unless (integerp level) 1119 (cl-check-type level integer)
1120 (signal 'wrong-type-argument 1120 (when (and ttl (< level 0))
1121 (list 'integerp level))) 1121 ;; testcover: Never reached because a title may not have a negative level
1122 (when ttl 1122 (signal 'args-out-of-range
1123 (unless (or (not (rst-Ttl-level ttl)) 1123 '("Top level node must not have a title.")))
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) 1124 level)
1132 1125
1133(defun rst-Stn--validate-children (children ttl) 1126(defun rst-Stn--validate-children (children ttl)
1134 ;; testcover: ok. 1127 ;; testcover: ok.
1135 "Return valid CHILDREN for TTL or signal error." 1128 "Return valid CHILDREN for TTL or signal error."
1136 (unless (listp children) 1129 (cl-check-type children list)
1137 (signal 'wrong-type-argument 1130 (dolist (child children)
1138 (list 'listp children))) 1131 (cl-check-type child rst-Stn))
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) 1132 (unless (or ttl children)
1145 (signal 'args-out-of-range 1133 (signal 'args-out-of-range
1146 '("A missing node must have children."))) 1134 '("A missing node must have children.")))
@@ -1152,9 +1140,7 @@ This type is immutable."
1152 ;; testcover: ok. 1140 ;; testcover: ok.
1153 "Return the beginning of the title of SELF. 1141 "Return the beginning of the title of SELF.
1154Handles missing node properly." 1142Handles missing node properly."
1155 (unless (rst-Stn-p self) 1143 (cl-check-type self rst-Stn)
1156 (signal 'wrong-type-argument
1157 (list 'rst-Stn-p self)))
1158 (let ((ttl (rst-Stn-ttl self))) 1144 (let ((ttl (rst-Stn-ttl self)))
1159 (if ttl 1145 (if ttl
1160 (rst-Ttl-get-title-beginning ttl) 1146 (rst-Ttl-get-title-beginning ttl)
@@ -1164,9 +1150,7 @@ Handles missing node properly."
1164 ;; testcover: ok. 1150 ;; testcover: ok.
1165 "Return title text of SELF or DEFAULT if SELF is a missing node. 1151 "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." 1152For a missing node and no DEFAULT given return a standard title text."
1167 (unless (rst-Stn-p self) 1153 (cl-check-type self rst-Stn)
1168 (signal 'wrong-type-argument
1169 (list 'rst-Stn-p self)))
1170 (let ((ttl (rst-Stn-ttl self))) 1154 (let ((ttl (rst-Stn-ttl self)))
1171 (cond 1155 (cond
1172 (ttl 1156 (ttl
@@ -1177,9 +1161,7 @@ For a missing node and no DEFAULT given return a standard title text."
1177(defun rst-Stn-is-top (self) 1161(defun rst-Stn-is-top (self)
1178 ;; testcover: ok. 1162 ;; testcover: ok.
1179 "Return non-nil if SELF is a top level node." 1163 "Return non-nil if SELF is a top level node."
1180 (unless (rst-Stn-p self) 1164 (cl-check-type self rst-Stn)
1181 (signal 'wrong-type-argument
1182 (list 'rst-Stn-p self)))
1183 (< (rst-Stn-level self) 0)) 1165 (< (rst-Stn-level self) 0))
1184 1166
1185 1167
@@ -1203,13 +1185,13 @@ as well but give an additional message."
1203 (forwarder-function (intern forwarder-function-name))) 1185 (forwarder-function (intern forwarder-function-name)))
1204 (unless (fboundp forwarder-function) 1186 (unless (fboundp forwarder-function)
1205 (defalias forwarder-function 1187 (defalias forwarder-function
1206 (lexical-let ((key key) (def def)) 1188 (lambda ()
1207 (lambda () 1189 (interactive)
1208 (interactive) 1190 (call-interactively def)
1209 (call-interactively def) 1191 (message "[Deprecated use of key %s; use key %s instead]"
1210 (message "[Deprecated use of key %s; use key %s instead]" 1192 (key-description (this-command-keys))
1211 (key-description (this-command-keys)) 1193 (key-description key)))
1212 (key-description key)))) 1194 ;; FIXME: In Emacs-25 we could use (:documentation ...) instead.
1213 (format "Deprecated binding for %s, use \\[%s] instead." 1195 (format "Deprecated binding for %s, use \\[%s] instead."
1214 def def))) 1196 def def)))
1215 (dolist (dep-key deprecated) 1197 (dolist (dep-key deprecated)
@@ -1220,40 +1202,40 @@ as well but give an additional message."
1220 (let ((map (make-sparse-keymap))) 1202 (let ((map (make-sparse-keymap)))
1221 1203
1222 ;; \C-c is the general keymap. 1204 ;; \C-c is the general keymap.
1223 (rst-define-key map [?\C-c ?\C-h] 'describe-prefix-bindings) 1205 (rst-define-key map [?\C-c ?\C-h] #'describe-prefix-bindings)
1224 1206
1225 ;; 1207 ;;
1226 ;; Section Adornments 1208 ;; Section Adornments
1227 ;; 1209 ;;
1228 ;; The adjustment function that adorns or rotates a section title. 1210 ;; The adjustment function that adorns or rotates a section title.
1229 (rst-define-key map [?\C-c ?\C-=] 'rst-adjust [?\C-c ?\C-a t]) 1211 (rst-define-key map [?\C-c ?\C-=] #'rst-adjust [?\C-c ?\C-a t])
1230 (rst-define-key map [?\C-=] 'rst-adjust) ; Does not work on macOS and 1212 (rst-define-key map [?\C-=] #'rst-adjust) ; Does not work on macOS and
1231 ; on consoles. 1213 ; on consoles.
1232 1214
1233 ;; \C-c \C-a is the keymap for adornments. 1215 ;; \C-c \C-a is the keymap for adornments.
1234 (rst-define-key map [?\C-c ?\C-a ?\C-h] 'describe-prefix-bindings) 1216 (rst-define-key map [?\C-c ?\C-a ?\C-h] #'describe-prefix-bindings)
1235 ;; Another binding which works with all types of input. 1217 ;; Another binding which works with all types of input.
1236 (rst-define-key map [?\C-c ?\C-a ?\C-a] 'rst-adjust) 1218 (rst-define-key map [?\C-c ?\C-a ?\C-a] #'rst-adjust)
1237 ;; Display the hierarchy of adornments implied by the current document 1219 ;; Display the hierarchy of adornments implied by the current document
1238 ;; contents. 1220 ;; contents.
1239 (rst-define-key map [?\C-c ?\C-a ?\C-d] 'rst-display-hdr-hierarchy) 1221 (rst-define-key map [?\C-c ?\C-a ?\C-d] #'rst-display-hdr-hierarchy)
1240 ;; Homogenize the adornments in the document. 1222 ;; Homogenize the adornments in the document.
1241 (rst-define-key map [?\C-c ?\C-a ?\C-s] 'rst-straighten-sections 1223 (rst-define-key map [?\C-c ?\C-a ?\C-s] #'rst-straighten-sections
1242 [?\C-c ?\C-s]) 1224 [?\C-c ?\C-s])
1243 1225
1244 ;; 1226 ;;
1245 ;; Section Movement and Selection 1227 ;; Section Movement and Selection
1246 ;; 1228 ;;
1247 ;; Mark the subsection where the cursor is. 1229 ;; Mark the subsection where the cursor is.
1248 (rst-define-key map [?\C-\M-h] 'rst-mark-section 1230 (rst-define-key map [?\C-\M-h] #'rst-mark-section
1249 ;; Same as mark-defun sgml-mark-current-element. 1231 ;; Same as mark-defun sgml-mark-current-element.
1250 [?\C-c ?\C-m]) 1232 [?\C-c ?\C-m])
1251 ;; Move backward/forward between section titles. 1233 ;; Move backward/forward between section titles.
1252 ;; FIXME: Also bind similar to outline mode. 1234 ;; FIXME: Also bind similar to outline mode.
1253 (rst-define-key map [?\C-\M-a] 'rst-backward-section 1235 (rst-define-key map [?\C-\M-a] #'rst-backward-section
1254 ;; Same as beginning-of-defun. 1236 ;; Same as beginning-of-defun.
1255 [?\C-c ?\C-n]) 1237 [?\C-c ?\C-n])
1256 (rst-define-key map [?\C-\M-e] 'rst-forward-section 1238 (rst-define-key map [?\C-\M-e] #'rst-forward-section
1257 ;; Same as end-of-defun. 1239 ;; Same as end-of-defun.
1258 [?\C-c ?\C-p]) 1240 [?\C-c ?\C-p])
1259 1241
@@ -1261,69 +1243,69 @@ as well but give an additional message."
1261 ;; Operating on regions 1243 ;; Operating on regions
1262 ;; 1244 ;;
1263 ;; \C-c \C-r is the keymap for regions. 1245 ;; \C-c \C-r is the keymap for regions.
1264 (rst-define-key map [?\C-c ?\C-r ?\C-h] 'describe-prefix-bindings) 1246 (rst-define-key map [?\C-c ?\C-r ?\C-h] #'describe-prefix-bindings)
1265 ;; Makes region a line-block. 1247 ;; Makes region a line-block.
1266 (rst-define-key map [?\C-c ?\C-r ?\C-l] 'rst-line-block-region 1248 (rst-define-key map [?\C-c ?\C-r ?\C-l] #'rst-line-block-region
1267 [?\C-c ?\C-d]) 1249 [?\C-c ?\C-d])
1268 ;; Shift region left or right according to tabs. 1250 ;; Shift region left or right according to tabs.
1269 (rst-define-key map [?\C-c ?\C-r tab] 'rst-shift-region 1251 (rst-define-key map [?\C-c ?\C-r tab] #'rst-shift-region
1270 [?\C-c ?\C-r t] [?\C-c ?\C-l t]) 1252 [?\C-c ?\C-r t] [?\C-c ?\C-l t])
1271 1253
1272 ;; 1254 ;;
1273 ;; Operating on lists 1255 ;; Operating on lists
1274 ;; 1256 ;;
1275 ;; \C-c \C-l is the keymap for lists. 1257 ;; \C-c \C-l is the keymap for lists.
1276 (rst-define-key map [?\C-c ?\C-l ?\C-h] 'describe-prefix-bindings) 1258 (rst-define-key map [?\C-c ?\C-l ?\C-h] #'describe-prefix-bindings)
1277 ;; Makes paragraphs in region as a bullet list. 1259 ;; Makes paragraphs in region as a bullet list.
1278 (rst-define-key map [?\C-c ?\C-l ?\C-b] 'rst-bullet-list-region 1260 (rst-define-key map [?\C-c ?\C-l ?\C-b] #'rst-bullet-list-region
1279 [?\C-c ?\C-b]) 1261 [?\C-c ?\C-b])
1280 ;; Makes paragraphs in region as a enumeration. 1262 ;; Makes paragraphs in region as a enumeration.
1281 (rst-define-key map [?\C-c ?\C-l ?\C-e] 'rst-enumerate-region 1263 (rst-define-key map [?\C-c ?\C-l ?\C-e] #'rst-enumerate-region
1282 [?\C-c ?\C-e]) 1264 [?\C-c ?\C-e])
1283 ;; Converts bullets to an enumeration. 1265 ;; Converts bullets to an enumeration.
1284 (rst-define-key map [?\C-c ?\C-l ?\C-c] 'rst-convert-bullets-to-enumeration 1266 (rst-define-key map [?\C-c ?\C-l ?\C-c] #'rst-convert-bullets-to-enumeration
1285 [?\C-c ?\C-v]) 1267 [?\C-c ?\C-v])
1286 ;; Make sure that all the bullets in the region are consistent. 1268 ;; Make sure that all the bullets in the region are consistent.
1287 (rst-define-key map [?\C-c ?\C-l ?\C-s] 'rst-straighten-bullets-region 1269 (rst-define-key map [?\C-c ?\C-l ?\C-s] #'rst-straighten-bullets-region
1288 [?\C-c ?\C-w]) 1270 [?\C-c ?\C-w])
1289 ;; Insert a list item. 1271 ;; Insert a list item.
1290 (rst-define-key map [?\C-c ?\C-l ?\C-i] 'rst-insert-list) 1272 (rst-define-key map [?\C-c ?\C-l ?\C-i] #'rst-insert-list)
1291 1273
1292 ;; 1274 ;;
1293 ;; Table-of-Contents Features 1275 ;; Table-of-Contents Features
1294 ;; 1276 ;;
1295 ;; \C-c \C-t is the keymap for table of contents. 1277 ;; \C-c \C-t is the keymap for table of contents.
1296 (rst-define-key map [?\C-c ?\C-t ?\C-h] 'describe-prefix-bindings) 1278 (rst-define-key map [?\C-c ?\C-t ?\C-h] #'describe-prefix-bindings)
1297 ;; Enter a TOC buffer to view and move to a specific section. 1279 ;; Enter a TOC buffer to view and move to a specific section.
1298 (rst-define-key map [?\C-c ?\C-t ?\C-t] 'rst-toc) 1280 (rst-define-key map [?\C-c ?\C-t ?\C-t] #'rst-toc)
1299 ;; Insert a TOC here. 1281 ;; Insert a TOC here.
1300 (rst-define-key map [?\C-c ?\C-t ?\C-i] 'rst-toc-insert 1282 (rst-define-key map [?\C-c ?\C-t ?\C-i] #'rst-toc-insert
1301 [?\C-c ?\C-i]) 1283 [?\C-c ?\C-i])
1302 ;; Update the document's TOC (without changing the cursor position). 1284 ;; Update the document's TOC (without changing the cursor position).
1303 (rst-define-key map [?\C-c ?\C-t ?\C-u] 'rst-toc-update 1285 (rst-define-key map [?\C-c ?\C-t ?\C-u] #'rst-toc-update
1304 [?\C-c ?\C-u]) 1286 [?\C-c ?\C-u])
1305 ;; Go to the section under the cursor (cursor must be in TOC). 1287 ;; Go to the section under the cursor (cursor must be in internal TOC).
1306 (rst-define-key map [?\C-c ?\C-t ?\C-j] 'rst-goto-section 1288 (rst-define-key map [?\C-c ?\C-t ?\C-j] #'rst-toc-follow-link
1307 [?\C-c ?\C-f]) 1289 [?\C-c ?\C-f])
1308 1290
1309 ;; 1291 ;;
1310 ;; Converting Documents from Emacs 1292 ;; Converting Documents from Emacs
1311 ;; 1293 ;;
1312 ;; \C-c \C-c is the keymap for compilation. 1294 ;; \C-c \C-c is the keymap for compilation.
1313 (rst-define-key map [?\C-c ?\C-c ?\C-h] 'describe-prefix-bindings) 1295 (rst-define-key map [?\C-c ?\C-c ?\C-h] #'describe-prefix-bindings)
1314 ;; Run one of two pre-configured toolset commands on the document. 1296 ;; Run one of two pre-configured toolset commands on the document.
1315 (rst-define-key map [?\C-c ?\C-c ?\C-c] 'rst-compile 1297 (rst-define-key map [?\C-c ?\C-c ?\C-c] #'rst-compile
1316 [?\C-c ?1]) 1298 [?\C-c ?1])
1317 (rst-define-key map [?\C-c ?\C-c ?\C-a] 'rst-compile-alt-toolset 1299 (rst-define-key map [?\C-c ?\C-c ?\C-a] #'rst-compile-alt-toolset
1318 [?\C-c ?2]) 1300 [?\C-c ?2])
1319 ;; Convert the active region to pseudo-xml using the docutils tools. 1301 ;; Convert the active region to pseudo-xml using the docutils tools.
1320 (rst-define-key map [?\C-c ?\C-c ?\C-x] 'rst-compile-pseudo-region 1302 (rst-define-key map [?\C-c ?\C-c ?\C-x] #'rst-compile-pseudo-region
1321 [?\C-c ?3]) 1303 [?\C-c ?3])
1322 ;; Convert the current document to PDF and launch a viewer on the results. 1304 ;; Convert the current document to PDF and launch a viewer on the results.
1323 (rst-define-key map [?\C-c ?\C-c ?\C-p] 'rst-compile-pdf-preview 1305 (rst-define-key map [?\C-c ?\C-c ?\C-p] #'rst-compile-pdf-preview
1324 [?\C-c ?4]) 1306 [?\C-c ?4])
1325 ;; Convert the current document to S5 slides and view in a web browser. 1307 ;; Convert the current document to S5 slides and view in a web browser.
1326 (rst-define-key map [?\C-c ?\C-c ?\C-s] 'rst-compile-slides-preview 1308 (rst-define-key map [?\C-c ?\C-c ?\C-s] #'rst-compile-slides-preview
1327 [?\C-c ?5]) 1309 [?\C-c ?5])
1328 1310
1329 map) 1311 map)
@@ -1333,7 +1315,8 @@ This inherits from Text mode.")
1333 1315
1334;; Abbrevs. 1316;; Abbrevs.
1335(define-abbrev-table 'rst-mode-abbrev-table 1317(define-abbrev-table 'rst-mode-abbrev-table
1336 (mapcar (lambda (x) (append x '(nil 0 system))) 1318 (mapcar #'(lambda (x)
1319 (append x '(nil 0 system)))
1337 '(("contents" ".. contents::\n..\n ") 1320 '(("contents" ".. contents::\n..\n ")
1338 ("con" ".. contents::\n..\n ") 1321 ("con" ".. contents::\n..\n ")
1339 ("cont" "[...]") 1322 ("cont" "[...]")
@@ -1381,6 +1364,7 @@ The hook for `text-mode' is run before this one."
1381(require 'newcomment) 1364(require 'newcomment)
1382 1365
1383(defvar electric-pair-pairs) 1366(defvar electric-pair-pairs)
1367(defvar electric-indent-inhibit)
1384 1368
1385;; Use rst-mode for *.rst and *.rest files. Many ReStructured-Text files 1369;; Use rst-mode for *.rst and *.rest files. Many ReStructured-Text files
1386;; use *.txt, but this is too generic to be set as a default. 1370;; use *.txt, but this is too generic to be set as a default.
@@ -1411,10 +1395,10 @@ highlighting.
1411 (:seq hws-tag par-tag- bli-sfx)))) 1395 (:seq hws-tag par-tag- bli-sfx))))
1412 1396
1413 ;; Indenting and filling. 1397 ;; Indenting and filling.
1414 (setq-local indent-line-function 'rst-indent-line) 1398 (setq-local indent-line-function #'rst-indent-line)
1415 (setq-local adaptive-fill-mode t) 1399 (setq-local adaptive-fill-mode t)
1416 (setq-local adaptive-fill-regexp (rst-re 'hws-tag 'par-tag- "?" 'hws-tag)) 1400 (setq-local adaptive-fill-regexp (rst-re 'hws-tag 'par-tag- "?" 'hws-tag))
1417 (setq-local adaptive-fill-function 'rst-adaptive-fill) 1401 (setq-local adaptive-fill-function #'rst-adaptive-fill)
1418 (setq-local fill-paragraph-handle-comment nil) 1402 (setq-local fill-paragraph-handle-comment nil)
1419 1403
1420 ;; Comments. 1404 ;; Comments.
@@ -1430,18 +1414,18 @@ highlighting.
1430 1414
1431 ;; Commenting in reStructuredText is very special so use our own set of 1415 ;; Commenting in reStructuredText is very special so use our own set of
1432 ;; functions. 1416 ;; functions.
1433 (setq-local comment-line-break-function 'rst-comment-line-break) 1417 (setq-local comment-line-break-function #'rst-comment-line-break)
1434 (setq-local comment-indent-function 'rst-comment-indent) 1418 (setq-local comment-indent-function #'rst-comment-indent)
1435 (setq-local comment-insert-comment-function 'rst-comment-insert-comment) 1419 (setq-local comment-insert-comment-function #'rst-comment-insert-comment)
1436 (setq-local comment-region-function 'rst-comment-region) 1420 (setq-local comment-region-function #'rst-comment-region)
1437 (setq-local uncomment-region-function 'rst-uncomment-region) 1421 (setq-local uncomment-region-function #'rst-uncomment-region)
1438 1422
1439 (setq-local electric-pair-pairs '((?\" . ?\") (?\* . ?\*) (?\` . ?\`))) 1423 (setq-local electric-pair-pairs '((?\" . ?\") (?\* . ?\*) (?\` . ?\`)))
1440 1424
1441 ;; Imenu and which function. 1425 ;; Imenu and which function.
1442 ;; FIXME: Check documentation of `which-function' for alternative ways to 1426 ;; FIXME: Check documentation of `which-function' for alternative ways to
1443 ;; determine the current function name. 1427 ;; determine the current function name.
1444 (setq-local imenu-create-index-function 'rst-imenu-create-index) 1428 (setq-local imenu-create-index-function #'rst-imenu-create-index)
1445 1429
1446 ;; Font lock. 1430 ;; Font lock.
1447 (setq-local font-lock-defaults 1431 (setq-local font-lock-defaults
@@ -1449,7 +1433,7 @@ highlighting.
1449 t nil nil nil 1433 t nil nil nil
1450 (font-lock-multiline . t) 1434 (font-lock-multiline . t)
1451 (font-lock-mark-block-function . mark-paragraph))) 1435 (font-lock-mark-block-function . mark-paragraph)))
1452 (add-hook 'font-lock-extend-region-functions 'rst-font-lock-extend-region t) 1436 (add-hook 'font-lock-extend-region-functions #'rst-font-lock-extend-region t)
1453 1437
1454 ;; Text after a changed line may need new fontification. 1438 ;; Text after a changed line may need new fontification.
1455 (setq-local jit-lock-contextually t) 1439 (setq-local jit-lock-contextually t)
@@ -1562,9 +1546,9 @@ file."
1562 :type `(repeat 1546 :type `(repeat
1563 (group :tag "Adornment specification" 1547 (group :tag "Adornment specification"
1564 (choice :tag "Adornment character" 1548 (choice :tag "Adornment character"
1565 ,@(mapcar (lambda (char) 1549 ,@(mapcar #'(lambda (char)
1566 (list 'const 1550 (list 'const
1567 :tag (char-to-string char) char)) 1551 :tag (char-to-string char) char))
1568 rst-adornment-chars)) 1552 rst-adornment-chars))
1569 (radio :tag "Adornment type" 1553 (radio :tag "Adornment type"
1570 (const :tag "Overline and underline" over-and-under) 1554 (const :tag "Overline and underline" over-and-under)
@@ -1603,17 +1587,12 @@ search starts after this entry. Return nil if no new preferred
1603 ;; Start searching after the level of the previous adornment. 1587 ;; Start searching after the level of the previous adornment.
1604 (cdr (rst-Hdr-member-ado prev (rst-Hdr-preferred-adornments)))) 1588 (cdr (rst-Hdr-member-ado prev (rst-Hdr-preferred-adornments))))
1605 (rst-Hdr-preferred-adornments)))) 1589 (rst-Hdr-preferred-adornments))))
1606 (car 1590 (cl-find-if #'(lambda (cand)
1607 (rst-member-if (lambda (cand) 1591 (not (rst-Hdr-member-ado cand seen)))
1608 (not (rst-Hdr-member-ado cand seen))) 1592 candidates)))
1609 candidates))))
1610
1611(defun rst-delete-entire-line ()
1612 "Delete the entire current line without using the `kill-ring'."
1613 (delete-region (line-beginning-position)
1614 (line-beginning-position 2)))
1615 1593
1616(defun rst-update-section (hdr) 1594(defun rst-update-section (hdr)
1595 ;; testcover: ok.
1617 "Unconditionally update the style of the section header at point to HDR. 1596 "Unconditionally update the style of the section header at point to HDR.
1618If there are existing overline and/or underline from the 1597If there are existing overline and/or underline from the
1619existing adornment, they are removed before adding the 1598existing adornment, they are removed before adding the
@@ -1621,163 +1600,149 @@ requested adornment."
1621 (end-of-line) 1600 (end-of-line)
1622 (let ((indent (or (rst-Hdr-indent hdr) 0)) 1601 (let ((indent (or (rst-Hdr-indent hdr) 0))
1623 (marker (point-marker)) 1602 (marker (point-marker))
1624 len) 1603 new)
1625 1604
1626 ;; Fixup whitespace at the beginning and end of the line. 1605 ;; Fixup whitespace at the beginning and end of the line.
1627 (beginning-of-line) 1606 (1value
1607 (rst-forward-line-strict 0))
1628 (delete-horizontal-space) 1608 (delete-horizontal-space)
1629 (insert (make-string indent ? )) 1609 (insert (make-string indent ? ))
1630
1631 (end-of-line) 1610 (end-of-line)
1632 (delete-horizontal-space) 1611 (delete-horizontal-space)
1633 1612 (setq new (make-string (+ (current-column) indent) (rst-Hdr-get-char hdr)))
1634 ;; Set the current column, we're at the end of the title line.
1635 (setq len (+ (current-column) indent))
1636 1613
1637 ;; Remove previous line if it is an adornment. 1614 ;; Remove previous line if it is an adornment.
1638 (save-excursion 1615 ;; FIXME refactoring: Check whether this deletes `hdr' which *has* all the
1639 (forward-line -1) ;; FIXME testcover: Doesn't work when in first line of 1616 ;; data necessary.
1640 ;; buffer. 1617 (when (and (rst-forward-line-looking-at -1 'ado-beg-2-1)
1641 (if (and (looking-at (rst-re 'ado-beg-2-1))
1642 ;; Avoid removing the underline of a title right above us. 1618 ;; Avoid removing the underline of a title right above us.
1643 (save-excursion (forward-line -1) 1619 (not (rst-forward-line-looking-at -2 'ttl-beg-1)))
1644 (not (looking-at (rst-re 'ttl-beg-1))))) 1620 (rst-delete-entire-line -1))
1645 (rst-delete-entire-line)))
1646 1621
1647 ;; Remove following line if it is an adornment. 1622 ;; Remove following line if it is an adornment.
1648 (save-excursion 1623 (when (rst-forward-line-looking-at +1 'ado-beg-2-1)
1649 (forward-line +1) ;; FIXME testcover: Doesn't work when in last line 1624 (rst-delete-entire-line +1))
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)
1660 (save-excursion
1661 (beginning-of-line)
1662 (open-line 1)
1663 (insert (make-string len (rst-Hdr-get-char hdr)))))
1664 1625
1665 ;; Insert underline. 1626 ;; Insert underline.
1666 (1value ;; Line has been inserted above. 1627 (unless (rst-forward-line-strict +1)
1667 (forward-line +1)) 1628 ;; Normalize buffer by adding final newline.
1629 (newline 1))
1668 (open-line 1) 1630 (open-line 1)
1669 (insert (make-string len (rst-Hdr-get-char hdr))) 1631 (insert new)
1632
1633 ;; Insert overline.
1634 (when (rst-Hdr-is-over-and-under hdr)
1635 (1value ; Underline inserted above.
1636 (rst-forward-line-strict -1))
1637 (open-line 1)
1638 (insert new))
1670 1639
1671 (1value ;; Line has been inserted above.
1672 (forward-line +1))
1673 (goto-char marker))) 1640 (goto-char marker)))
1674 1641
1675(defun rst-classify-adornment (adornment end) 1642(defun rst-classify-adornment (adornment end &optional accept-over-only)
1643 ;; testcover: ok.
1676 "Classify adornment string for section titles and transitions. 1644 "Classify adornment string for section titles and transitions.
1677ADORNMENT is the complete adornment string as found in the buffer 1645ADORNMENT is the complete adornment string as found in the buffer
1678with optional trailing whitespace. END is the point after the 1646with optional trailing whitespace. END is the point after the
1679last character of ADORNMENT. Return a `rst-Ttl' or nil if no 1647last character of ADORNMENT. Return a `rst-Ttl' or nil if no
1680syntactically valid adornment is found." 1648syntactically valid adornment is found. If ACCEPT-OVER-ONLY an
1649overline with a missing underline is accepted as valid and
1650returned."
1681 (save-excursion 1651 (save-excursion
1682 (save-match-data 1652 (save-match-data
1683 (when (string-match (rst-re 'ado-beg-2-1) adornment) 1653 (when (string-match (rst-re 'ado-beg-2-1) adornment)
1684 (goto-char end) 1654 (goto-char end)
1685 (let* ((ado-ch (string-to-char (match-string 2 adornment))) 1655 (let* ((ado-ch (string-to-char (match-string 2 adornment)))
1686 (ado-re (rst-re ado-ch 'adorep3-hlp)) 1656 (ado-re (rst-re ado-ch 'adorep3-hlp)) ; RE matching the
1687 (end-pnt (point)) 1657 ; adornment.
1688 (beg-pnt (progn 1658 (beg-pnt (progn
1689 (1value ;; No lines may be left to move. 1659 (1value
1690 (forward-line 0)) 1660 (rst-forward-line-strict 0))
1691 (point))) 1661 (point)))
1692 (nxt-emp ; Next line nonexistent or empty 1662 (nxt-emp ; Next line nonexistent or empty
1693 (save-excursion 1663 (not (rst-forward-line-looking-at +1 'lin-end #'not)))
1694 (or (not (zerop (forward-line 1)))
1695 ;; FIXME testcover: Add test classifying at the end of
1696 ;; buffer.
1697 (looking-at (rst-re 'lin-end)))))
1698 (prv-emp ; Previous line nonexistent or empty 1664 (prv-emp ; Previous line nonexistent or empty
1699 (save-excursion 1665 (not (rst-forward-line-looking-at -1 'lin-end #'not)))
1700 (or (not (zerop (forward-line -1)))
1701 (looking-at (rst-re 'lin-end)))))
1702 txt-blw 1666 txt-blw
1703 (ttl-blw ; Title found below starting here. 1667 (ttl-blw ; Title found below starting here.
1704 (save-excursion 1668 (rst-forward-line-looking-at
1705 (and 1669 +1 'ttl-beg-1
1706 (zerop (forward-line 1)) ;; FIXME testcover: Add test 1670 #'(lambda (mtcd)
1707 ;; classifying at the end of 1671 (when mtcd
1708 ;; buffer. 1672 (setq txt-blw (match-string-no-properties 1))
1709 (looking-at (rst-re 'ttl-beg-1)) 1673 (point)))))
1710 (setq txt-blw (match-string-no-properties 1))
1711 (point))))
1712 txt-abv 1674 txt-abv
1713 (ttl-abv ; Title found above starting here. 1675 (ttl-abv ; Title found above starting here.
1714 (save-excursion 1676 (rst-forward-line-looking-at
1715 (and 1677 -1 'ttl-beg-1
1716 (zerop (forward-line -1)) 1678 #'(lambda (mtcd)
1717 (looking-at (rst-re 'ttl-beg-1)) 1679 (when mtcd
1718 (setq txt-abv (match-string-no-properties 1)) 1680 (setq txt-abv (match-string-no-properties 1))
1719 (point)))) 1681 (point)))))
1720 (und-fnd ; Matching underline found starting here. 1682 (und-fnd ; Matching underline found starting here.
1721 (save-excursion 1683 (and ttl-blw
1722 (and ttl-blw 1684 (rst-forward-line-looking-at
1723 (zerop (forward-line 2)) ;; FIXME testcover: Add test 1685 +2 (list ado-re 'lin-end)
1724 ;; classifying at the end of 1686 #'(lambda (mtcd)
1725 ;; buffer. 1687 (when mtcd
1726 (looking-at (rst-re ado-re 'lin-end)) 1688 (point))))))
1727 (point))))
1728 (ovr-fnd ; Matching overline found starting here. 1689 (ovr-fnd ; Matching overline found starting here.
1729 (save-excursion 1690 (and ttl-abv
1730 (and ttl-abv 1691 (rst-forward-line-looking-at
1731 (zerop (forward-line -2)) 1692 -2 (list ado-re 'lin-end)
1732 (looking-at (rst-re ado-re 'lin-end)) 1693 #'(lambda (mtcd)
1733 (point)))) 1694 (when mtcd
1734 ado ind txt beg-ovr end-ovr beg-txt end-txt beg-und end-und) 1695 (point))))))
1696 (und-wng ; Wrong underline found starting here.
1697 (and ttl-blw
1698 (not und-fnd)
1699 (rst-forward-line-looking-at
1700 +2 'ado-beg-2-1
1701 #'(lambda (mtcd)
1702 (when mtcd
1703 (point))))))
1704 (ovr-wng ; Wrong overline found starting here.
1705 (and ttl-abv (not ovr-fnd)
1706 (rst-forward-line-looking-at
1707 -2 'ado-beg-2-1
1708 #'(lambda (mtcd)
1709 (when (and
1710 mtcd
1711 ;; An adornment above may be a legal
1712 ;; adornment for the line above - consider it
1713 ;; a wrong overline only when it is equally
1714 ;; long.
1715 (equal
1716 (length (match-string-no-properties 1))
1717 (length adornment)))
1718 (point)))))))
1735 (cond 1719 (cond
1736 ((and nxt-emp prv-emp) 1720 ((and nxt-emp prv-emp)
1737 ;; A transition. 1721 ;; A transition.
1738 (setq ado (rst-Ado-new-transition) 1722 (rst-Ttl-from-buffer (rst-Ado-new-transition)
1739 beg-txt beg-pnt 1723 nil beg-pnt nil nil))
1740 end-txt end-pnt)) 1724 (ovr-fnd ; Prefer overline match over underline match.
1741 ((or und-fnd ovr-fnd)
1742 ;; An overline with an underline. 1725 ;; An overline with an underline.
1743 (setq ado (rst-Ado-new-over-and-under ado-ch)) 1726 (rst-Ttl-from-buffer (rst-Ado-new-over-and-under ado-ch)
1744 (let (;; Prefer overline match over underline match. 1727 ovr-fnd ttl-abv beg-pnt txt-abv))
1745 (und-pnt (if ovr-fnd beg-pnt und-fnd)) 1728 (und-fnd
1746 (ovr-pnt (if ovr-fnd ovr-fnd beg-pnt)) 1729 ;; An overline with an underline.
1747 (txt-pnt (if ovr-fnd ttl-abv ttl-blw))) 1730 (rst-Ttl-from-buffer (rst-Ado-new-over-and-under ado-ch)
1748 (goto-char ovr-pnt) 1731 beg-pnt ttl-blw und-fnd txt-blw))
1749 (setq beg-ovr (point) 1732 ((and ttl-abv (not ovr-wng))
1750 end-ovr (line-end-position))
1751 (goto-char txt-pnt)
1752 (setq beg-txt (point)
1753 end-txt (line-end-position)
1754 ind (current-indentation)
1755 txt (if ovr-fnd txt-abv txt-blw))
1756 (goto-char und-pnt)
1757 (setq beg-und (point)
1758 end-und (line-end-position))))
1759 (ttl-abv
1760 ;; An underline. 1733 ;; An underline.
1761 (setq ado (rst-Ado-new-simple ado-ch) 1734 (rst-Ttl-from-buffer (rst-Ado-new-simple ado-ch)
1762 beg-und beg-pnt 1735 nil ttl-abv beg-pnt txt-abv))
1763 end-und end-pnt) 1736 ((and accept-over-only ttl-blw (not und-wng))
1764 (goto-char ttl-abv) 1737 ;; An overline with a missing underline.
1765 (setq beg-txt (point) 1738 (rst-Ttl-from-buffer (rst-Ado-new-over-and-under ado-ch)
1766 end-txt (line-end-position) 1739 beg-pnt ttl-blw nil txt-blw))
1767 ind (current-indentation)
1768 txt txt-abv))
1769 (t 1740 (t
1770 ;; Invalid adornment. 1741 ;; Invalid adornment.
1771 (setq ado nil))) 1742 nil)))))))
1772 (if ado
1773 (rst-Ttl-new ado
1774 (list
1775 (or beg-ovr beg-txt)
1776 (or end-und end-txt)
1777 beg-ovr end-ovr beg-txt end-txt beg-und end-und)
1778 ind txt)))))))
1779 1743
1780(defun rst-ttl-at-point () 1744(defun rst-ttl-at-point ()
1745 ;; testcover: ok.
1781 "Find a section title line around point and return its characteristics. 1746 "Find a section title line around point and return its characteristics.
1782If the point is on an adornment line find the respective title 1747If the point is on an adornment line find the respective title
1783line. If the point is on an empty line check previous or next 1748line. If the point is on an empty line check previous or next
@@ -1785,89 +1750,57 @@ line whether it is a suitable title line and use it if so. If
1785point is on a suitable title line use it. Return a `rst-Ttl' for 1750point is on a suitable title line use it. Return a `rst-Ttl' for
1786a section header or nil if no title line is found." 1751a section header or nil if no title line is found."
1787 (save-excursion 1752 (save-excursion
1788 (1value ;; No lines may be left to move. 1753 (save-match-data
1789 (forward-line 0)) 1754 (1value
1790 (let ((orig-pnt (point)) 1755 (rst-forward-line-strict 0))
1791 (orig-end (line-end-position))) 1756 (let* (cnd-beg ; Beginning of a title candidate.
1792 (cond 1757 cnd-txt ; Text of a title candidate.
1793 ((looking-at (rst-re 'ado-beg-2-1)) 1758 (cnd-fun #'(lambda (mtcd) ; Function setting title candidate data.
1794 ;; Adornment found - consider it. 1759 (when mtcd
1795 (let ((char (string-to-char (match-string-no-properties 2))) 1760 (setq cnd-beg (match-beginning 0))
1796 (r (rst-classify-adornment (match-string-no-properties 0) 1761 (setq cnd-txt (match-string-no-properties 1))
1797 (match-end 0)))) 1762 t)))
1798 (cond 1763 ttl)
1799 ((not r) 1764 (cond
1800 ;; Invalid adornment - check whether this is an overline with 1765 ((looking-at (rst-re 'ado-beg-2-1))
1801 ;; missing underline. 1766 ;; Adornment found - consider it.
1802 (if (and 1767 (setq ttl (rst-classify-adornment (match-string-no-properties 0)
1803 (zerop (forward-line 1)) 1768 (match-end 0) t)))
1804 (looking-at (rst-re 'ttl-beg-1))) 1769 ((looking-at (rst-re 'lin-end))
1805 (rst-Ttl-new (rst-Ado-new-over-and-under char) 1770 ;; Empty line found - check surrounding lines for a title.
1806 (list orig-pnt (line-end-position) 1771 (or
1807 orig-pnt orig-end 1772 (rst-forward-line-looking-at -1 'ttl-beg-1 cnd-fun)
1808 (point) (line-end-position) 1773 (rst-forward-line-looking-at +1 'ttl-beg-1 cnd-fun)))
1809 nil nil) 1774 ((looking-at (rst-re 'ttl-beg-1))
1810 (current-indentation) 1775 ;; Title line found - check for a following underline.
1811 (match-string-no-properties 1)))) 1776 (setq ttl (rst-forward-line-looking-at
1812 ((rst-Ado-is-transition (rst-Ttl-ado r)) 1777 1 'ado-beg-2-1
1813 nil) 1778 #'(lambda (mtcd)
1814 ;; Return any other classification as is. 1779 (when mtcd
1815 (r)))) 1780 (rst-classify-adornment
1816 ((looking-at (rst-re 'lin-end)) 1781 (match-string-no-properties 0) (match-end 0))))))
1817 ;; Empty line found - check surrounding lines for a title. 1782 ;; Title candidate found if no valid adornment found.
1818 (or 1783 (funcall cnd-fun (not ttl))))
1819 (save-excursion 1784 (cond
1820 (if (and (zerop (forward-line -1)) 1785 ((and ttl (rst-Ttl-is-section ttl))
1821 (looking-at (rst-re 'ttl-beg-1))) 1786 ttl)
1822 (rst-Ttl-new nil 1787 (cnd-beg
1823 (list (point) (line-end-position) 1788 (rst-Ttl-from-buffer nil nil cnd-beg nil cnd-txt)))))))
1824 nil nil
1825 (point) (line-end-position)
1826 nil nil)
1827 (current-indentation)
1828 (match-string-no-properties 1))))
1829 (save-excursion
1830 (if (and (zerop (forward-line 1))
1831 (looking-at (rst-re 'ttl-beg-1)))
1832 (rst-Ttl-new nil
1833 (list (point) (line-end-position)
1834 nil nil
1835 (point) (line-end-position)
1836 nil nil)
1837 (current-indentation)
1838 (match-string-no-properties 1))))))
1839 ((looking-at (rst-re 'ttl-beg-1))
1840 ;; Title line found - check for a following underline.
1841 (let ((txt (match-string-no-properties 1)))
1842 (or (rst-classify-adornment
1843 (buffer-substring-no-properties
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))))))))
1854 1789
1855;; The following function and variables are used to maintain information about 1790;; The following function and variables are used to maintain information about
1856;; current section adornment in a buffer local cache. Thus they can be used for 1791;; current section adornment in a buffer local cache. Thus they can be used for
1857;; font-locking and manipulation commands. 1792;; font-locking and manipulation commands.
1858 1793
1859(defvar rst-all-ttls-cache nil 1794(defvar-local rst-all-ttls-cache nil
1860 "All section adornments in the buffer as found by `rst-all-ttls'. 1795 "All section adornments in the buffer as found by `rst-all-ttls'.
1861Set to t when no section adornments were found.") 1796Set to t when no section adornments were found.")
1862(make-variable-buffer-local 'rst-all-ttls-cache)
1863 1797
1864;; FIXME: If this variable is set to a different value font-locking of section 1798;; FIXME: If this variable is set to a different value font-locking of section
1865;; headers is wrong. 1799;; headers is wrong.
1866(defvar rst-hdr-hierarchy-cache nil 1800(defvar-local rst-hdr-hierarchy-cache nil
1867 "Section hierarchy in the buffer as determined by `rst-hdr-hierarchy'. 1801 "Section hierarchy in the buffer as determined by `rst-hdr-hierarchy'.
1868Set to t when no section adornments were found. 1802Set to t when no section adornments were found.
1869Value depends on `rst-all-ttls-cache'.") 1803Value depends on `rst-all-ttls-cache'.")
1870(make-variable-buffer-local 'rst-hdr-hierarchy-cache)
1871 1804
1872(rst-testcover-add-1value 'rst-reset-section-caches) 1805(rst-testcover-add-1value 'rst-reset-section-caches)
1873(defun rst-reset-section-caches () 1806(defun rst-reset-section-caches ()
@@ -1876,94 +1809,92 @@ Should be called by interactive functions which deal with sections."
1876 (setq rst-all-ttls-cache nil 1809 (setq rst-all-ttls-cache nil
1877 rst-hdr-hierarchy-cache nil)) 1810 rst-hdr-hierarchy-cache nil))
1878 1811
1812(defun rst-all-ttls-compute ()
1813 ;; testcover: ok.
1814 "Return a list of `rst-Ttl' for current buffer with ascending line number."
1815 (save-excursion
1816 (save-match-data
1817 (let (ttls)
1818 (goto-char (point-min))
1819 ;; Iterate over all the section titles/adornments in the file.
1820 (while (re-search-forward (rst-re 'ado-beg-2-1) nil t)
1821 (let ((ttl (rst-classify-adornment
1822 (match-string-no-properties 0) (point))))
1823 (when (and ttl (rst-Ttl-is-section ttl))
1824 (when (rst-Ttl-hdr ttl)
1825 (push ttl ttls))
1826 (goto-char (rst-Ttl-get-end ttl)))))
1827 (nreverse ttls)))))
1828
1879(defun rst-all-ttls () 1829(defun rst-all-ttls ()
1880 "Return all the section adornments in the current buffer. 1830 "Return all the section adornments in the current buffer.
1881Return a list of `rst-Ttl' with ascending line number. 1831Return a list of `rst-Ttl' with ascending line number.
1882 1832
1883Uses and sets `rst-all-ttls-cache'." 1833Uses and sets `rst-all-ttls-cache'."
1884 (unless rst-all-ttls-cache 1834 (unless rst-all-ttls-cache
1885 (let (positions) 1835 (setq rst-all-ttls-cache (or (rst-all-ttls-compute) t)))
1886 ;; Iterate over all the section titles/adornments in the file.
1887 (save-excursion
1888 (save-match-data
1889 (goto-char (point-min))
1890 (while (re-search-forward (rst-re 'ado-beg-2-1) nil t)
1891 (let ((ttl (rst-classify-adornment
1892 (match-string-no-properties 0) (point))))
1893 (when (and ttl (rst-Ado-is-section (rst-Ttl-ado ttl)))
1894 (when (rst-Ttl-evaluate-hdr ttl)
1895 (push ttl positions))
1896 (goto-char (rst-Ttl-get-end ttl)))))
1897 (setq positions (nreverse positions))
1898 (setq rst-all-ttls-cache (or positions t))))))
1899 (if (eq rst-all-ttls-cache t) 1836 (if (eq rst-all-ttls-cache t)
1900 nil 1837 nil
1901 (mapcar 'rst-Ttl-copy rst-all-ttls-cache))) 1838 (copy-sequence rst-all-ttls-cache)))
1902 1839
1903(defun rst-infer-hdr-hierarchy (hdrs) 1840(defun rst-infer-hdr-hierarchy (hdrs)
1841 ;; testcover: ok.
1904 "Build a hierarchy from HDRS. 1842 "Build a hierarchy from HDRS.
1905HDRS reflects the order in which the headers appear in the 1843HDRS reflects the order in which the headers appear in the
1906buffer. Return a `rst-Hdr' list representing the hierarchy of 1844buffer. Return a `rst-Hdr' list representing the hierarchy of
1907headers in the buffer. Indentation is unified." 1845headers in the buffer. Indentation is unified."
1908 (let (ado2indents) 1846 (let (ado2indents) ; Asscociates `rst-Ado' with the set of indents seen for
1847 ; it.
1909 (dolist (hdr hdrs) 1848 (dolist (hdr hdrs)
1910 (let* ((ado (rst-Hdr-ado hdr)) 1849 (let* ((ado (rst-Hdr-ado hdr))
1911 (indent (rst-Hdr-indent hdr)) 1850 (indent (rst-Hdr-indent hdr))
1912 (found (assoc ado ado2indents))) 1851 (found (assoc ado ado2indents)))
1913 (if found 1852 (if found
1914 (unless (member indent (cdr found)) 1853 (setcdr found (cl-adjoin indent (cdr found)))
1915 ;; Append newly found indent.
1916 (setcdr found (append (cdr found) (list indent))))
1917 (push (list ado indent) ado2indents)))) 1854 (push (list ado indent) ado2indents))))
1918 (mapcar (lambda (ado_indents) 1855 (mapcar (cl-function
1919 (let ((ado (car ado_indents)) 1856 (lambda ((ado consistent &rest inconsistent))
1920 (indents (cdr ado_indents))) 1857 (rst-Hdr-new ado (if inconsistent
1921 (rst-Hdr-new 1858 rst-default-indent
1922 ado 1859 consistent))))
1923 (if (> (length indents) 1)
1924 ;; Indentations used inconsistently - use default.
1925 rst-default-indent
1926 ;; Only one indentation used - use this.
1927 (car indents)))))
1928 (nreverse ado2indents)))) 1860 (nreverse ado2indents))))
1929 1861
1930(defun rst-hdr-hierarchy (&optional ignore-current) 1862(defun rst-hdr-hierarchy (&optional ignore-position)
1863 ;; testcover: ok.
1931 "Return the hierarchy of section titles in the file as a `rst-Hdr' list. 1864 "Return the hierarchy of section titles in the file as a `rst-Hdr' list.
1932Each returned element may be used directly to create a section 1865Each returned element may be used directly to create a section
1933adornment on that level. If IGNORE-CURRENT a title found on the 1866adornment on that level. If IGNORE-POSITION a title containing
1934current line is not taken into account when building the 1867this position is not taken into account when building the
1935hierarchy unless it appears again elsewhere. This catches cases 1868hierarchy unless it appears again elsewhere. This catches cases
1936where the current title is edited and may not be final regarding 1869where the current title is edited and may not be final regarding
1937its level. 1870its level.
1938 1871
1939Uses and sets `rst-hdr-hierarchy-cache' unless IGNORE-CURRENT is 1872Uses and sets `rst-hdr-hierarchy-cache' unless IGNORE-POSITION is
1940given." 1873given."
1941 (let* ((all-ttls (rst-all-ttls)) 1874 (let* ((all-ttls (rst-all-ttls))
1942 (ignore-position (if ignore-current
1943 (line-beginning-position)))
1944 (ignore-ttl 1875 (ignore-ttl
1945 (if ignore-position 1876 (if ignore-position
1946 (car (member-if 1877 (cl-find-if
1947 (lambda (ttl) 1878 #'(lambda (ttl)
1948 (equal ignore-position (rst-Ttl-get-title-beginning ttl))) 1879 (equal (rst-Ttl-contains ttl ignore-position) 0))
1949 all-ttls)))) 1880 all-ttls)))
1950 (really-ignore 1881 (really-ignore
1951 (if ignore-ttl 1882 (if ignore-ttl
1952 (<= (count-if 1883 (<= (cl-count-if
1953 (lambda (ttl) 1884 #'(lambda (ttl)
1954 (rst-Ado-equal (rst-Ttl-ado ignore-ttl) (rst-Ttl-ado ttl))) 1885 (rst-Ado-equal (rst-Ttl-ado ignore-ttl)
1886 (rst-Ttl-ado ttl)))
1955 all-ttls) 1887 all-ttls)
1956 1))) 1888 1)))
1957 (real-ttls (delq (if really-ignore ignore-ttl) all-ttls))) 1889 (real-ttls (delq (if really-ignore ignore-ttl) all-ttls)))
1958 (mapcar ;; Protect cache. 1890 (copy-sequence ; Protect cache.
1959 'rst-Hdr-copy 1891 (if (and (not ignore-position) rst-hdr-hierarchy-cache)
1960 (if (and (not ignore-current) rst-hdr-hierarchy-cache)
1961 (if (eq rst-hdr-hierarchy-cache t) 1892 (if (eq rst-hdr-hierarchy-cache t)
1962 nil 1893 nil
1963 rst-hdr-hierarchy-cache) 1894 rst-hdr-hierarchy-cache)
1964 (let ((r (rst-infer-hdr-hierarchy (mapcar 'rst-Ttl-hdr real-ttls)))) 1895 (let ((r (rst-infer-hdr-hierarchy (mapcar #'rst-Ttl-hdr real-ttls))))
1965 (setq rst-hdr-hierarchy-cache 1896 (setq rst-hdr-hierarchy-cache
1966 (if ignore-current 1897 (if ignore-position
1967 ;; Clear cache reflecting that a possible update is not 1898 ;; Clear cache reflecting that a possible update is not
1968 ;; reflected. 1899 ;; reflected.
1969 nil 1900 nil
@@ -1971,48 +1902,43 @@ given."
1971 r))))) 1902 r)))))
1972 1903
1973(defun rst-all-ttls-with-level () 1904(defun rst-all-ttls-with-level ()
1905 ;; testcover: ok.
1974 "Return the section adornments with levels set according to hierarchy. 1906 "Return the section adornments with levels set according to hierarchy.
1975Return a list of `rst-Ttl' with ascending line number." 1907Return a list of (`rst-Ttl' . LEVEL) with ascending line number."
1976 (let ((hier (rst-Hdr-ado-map (rst-hdr-hierarchy)))) 1908 (let ((hier (rst-Hdr-ado-map (rst-hdr-hierarchy))))
1977 (mapcar 1909 (mapcar
1978 (lambda (ttl) 1910 #'(lambda (ttl)
1979 (rst-Ttl-set-level ttl (rst-Ado-position (rst-Ttl-ado ttl) hier)) 1911 (cons ttl (rst-Ado-position (rst-Ttl-ado ttl) hier)))
1980 ttl) 1912 (rst-all-ttls))))
1981 (rst-all-ttls))))
1982 1913
1983(defun rst-get-previous-hdr () 1914(defun rst-get-previous-hdr ()
1984 "Return the `rst-Hdr' before point or nil if none." 1915 "Return the `rst-Hdr' before point or nil if none."
1985 (let ((ttls (rst-all-ttls)) 1916 (let ((prev (cl-find-if #'(lambda (ttl)
1986 (curpos (line-beginning-position)) 1917 (< (rst-Ttl-contains ttl (point)) 0))
1987 prev) 1918 (rst-all-ttls)
1988 1919 :from-end t)))
1989 ;; Search for the adornments around the current line.
1990 (while (and ttls (< (rst-Ttl-get-title-beginning (car ttls)) curpos))
1991 (setq prev (car ttls)
1992 ttls (cdr ttls)))
1993 (and prev (rst-Ttl-hdr prev)))) 1920 (and prev (rst-Ttl-hdr prev))))
1994 1921
1995(defun rst-adornment-complete-p (ado indent) 1922(defun rst-adornment-complete-p (ado indent)
1996 "Return true if the adornment ADO around point is complete using INDENT. 1923 ;; testcover: ok.
1924 "Return t if the adornment ADO around point is complete using INDENT.
1997The adornment is complete if it is a completely correct 1925The adornment is complete if it is a completely correct
1998reStructuredText adornment for the title line at point. This 1926reStructuredText adornment for the title line at point. This
1999includes indentation and correct length of adornment lines." 1927includes indentation and correct length of adornment lines."
2000 ;; Note: we assume that the detection of the overline as being the underline 1928 ;; Note: we assume that the detection of the overline as being the underline
2001 ;; of a preceding title has already been detected, and has been eliminated 1929 ;; of a preceding title has already been detected, and has been eliminated
2002 ;; from the adornment that is given to us. 1930 ;; from the adornment that is given to us.
2003 (let ((exps (rst-re "^" (rst-Ado-char ado) 1931 (let ((exps (list "^" (rst-Ado-char ado)
2004 (format "\\{%d\\}" 1932 (format "\\{%d\\}"
2005 (+ (save-excursion 1933 (+ (save-excursion
2006 ;; Determine last column of title. 1934 ;; Determine last column of title.
2007 (end-of-line) 1935 (end-of-line)
2008 (current-column)) 1936 (current-column))
2009 indent)) "$"))) 1937 indent)) "$")))
2010 (and 1938 (and (rst-forward-line-looking-at +1 exps)
2011 (save-excursion (forward-line +1) 1939 (or (rst-Ado-is-simple ado)
2012 (looking-at exps)) 1940 (rst-forward-line-looking-at -1 exps))
2013 (or (rst-Ado-is-simple ado) 1941 t))) ; Normalize return value.
2014 (save-excursion (forward-line -1)
2015 (looking-at exps))))))
2016 1942
2017(defun rst-next-hdr (hdr hier prev down) 1943(defun rst-next-hdr (hdr hier prev down)
2018 ;; testcover: ok. 1944 ;; testcover: ok.
@@ -2042,6 +1968,7 @@ HIER is nil."
2042 1968
2043;; FIXME: A line "``/`` full" is not accepted as a section title. 1969;; FIXME: A line "``/`` full" is not accepted as a section title.
2044(defun rst-adjust (pfxarg) 1970(defun rst-adjust (pfxarg)
1971 ;; testcover: ok.
2045 "Auto-adjust the adornment around point. 1972 "Auto-adjust the adornment around point.
2046Adjust/rotate the section adornment for the section title around 1973Adjust/rotate the section adornment for the section title around
2047point or promote/demote the adornments inside the region, 1974point or promote/demote the adornments inside the region,
@@ -2056,7 +1983,7 @@ to deal with all the possible cases gracefully and to do \"the
2056right thing\" in all cases. 1983right thing\" in all cases.
2057 1984
2058See the documentations of `rst-adjust-section' and 1985See the documentations of `rst-adjust-section' and
2059`rst-promote-region' for full details. 1986`rst-adjust-region' for full details.
2060 1987
2061The method can take either (but not both) of 1988The method can take either (but not both) of
2062 1989
@@ -2067,28 +1994,18 @@ b. a negative numerical argument, which generally inverts the
2067 direction of search in the file or hierarchy. Invoke with C-- 1994 direction of search in the file or hierarchy. Invoke with C--
2068 prefix for example." 1995 prefix for example."
2069 (interactive "P") 1996 (interactive "P")
2070 1997 (let* ((origpt (point-marker))
2071 (let* (;; Save our original position on the current line.
2072 (origpt (point-marker))
2073
2074 (reverse-direction (and pfxarg (< (prefix-numeric-value pfxarg) 0))) 1998 (reverse-direction (and pfxarg (< (prefix-numeric-value pfxarg) 0)))
2075 (toggle-style (and pfxarg (not reverse-direction)))) 1999 (toggle-style (and pfxarg (not reverse-direction))))
2076
2077 (if (use-region-p) 2000 (if (use-region-p)
2078 ;; Adjust adornments within region. 2001 (rst-adjust-region (and pfxarg t))
2079 (rst-promote-region (and pfxarg t))
2080 ;; Adjust adornment around point.
2081 (let ((msg (rst-adjust-section toggle-style reverse-direction))) 2002 (let ((msg (rst-adjust-section toggle-style reverse-direction)))
2082 (when msg 2003 (when msg
2083 (apply 'message msg)))) 2004 (apply #'message msg))))
2084
2085 ;; Run the hooks to run after adjusting.
2086 (run-hooks 'rst-adjust-hook) 2005 (run-hooks 'rst-adjust-hook)
2087
2088 (rst-reset-section-caches) 2006 (rst-reset-section-caches)
2089 2007 (set-marker
2090 ;; Make sure to reset the cursor position properly after we're done. 2008 (goto-char origpt) nil)))
2091 (goto-char origpt)))
2092 2009
2093(defcustom rst-adjust-hook nil 2010(defcustom rst-adjust-hook nil
2094 "Hooks to be run after running `rst-adjust'." 2011 "Hooks to be run after running `rst-adjust'."
@@ -2116,8 +2033,77 @@ Argument PFXARG has the same meaning as for `rst-adjust'."
2116 (toggle-style (and pfxarg (not reverse-direction)))) 2033 (toggle-style (and pfxarg (not reverse-direction))))
2117 (rst-adjust-section toggle-style reverse-direction))) 2034 (rst-adjust-section toggle-style reverse-direction)))
2118 2035
2036(defun rst-adjust-new-hdr (toggle-style reverse ttl)
2037 ;; testcover: ok.
2038 "Return a new `rst-Hdr' for `rst-adjust-section' related to TTL.
2039TOGGLE-STYLE and REVERSE are from
2040`rst-adjust-section'. TOGGLE-STYLE may be consumed and thus is
2041returned.
2042
2043Return a list (HDR TOGGLE-STYLE MSG...). HDR is the result or
2044nil. TOGGLE-STYLE is the new TOGGLE-STYLE to use in the
2045caller. MSG is a list which is non-empty in case HDR is nil
2046giving an argument list for `message'."
2047 (save-excursion
2048 (goto-char (rst-Ttl-get-title-beginning ttl))
2049 (let ((indent (rst-Ttl-indent ttl))
2050 (ado (rst-Ttl-ado ttl))
2051 (prev (rst-get-previous-hdr))
2052 hdr-msg)
2053 (setq
2054 hdr-msg
2055 (cond
2056 ((rst-Ttl-is-candidate ttl)
2057 ;; Case 1: No adornment at all.
2058 (let ((hier (rst-hdr-hierarchy)))
2059 (if prev
2060 ;; Previous header exists - use it.
2061 (cond
2062 ;; Customization and parameters require that the previous level
2063 ;; is used - use it as is.
2064 ((or (and rst-new-adornment-down reverse)
2065 (and (not rst-new-adornment-down) (not reverse)))
2066 prev)
2067 ;; Advance one level down.
2068 ((rst-next-hdr prev hier prev t))
2069 ("Neither hierarchy nor preferences can suggest a deeper header"))
2070 ;; First header in the buffer - use the first adornment from
2071 ;; preferences or hierarchy.
2072 (let ((p (car (rst-Hdr-preferred-adornments)))
2073 (h (car hier)))
2074 (cond
2075 ((if reverse
2076 ;; Prefer hierarchy for downwards
2077 (or h p)
2078 ;; Prefer preferences for upwards
2079 (or p h)))
2080 ("No preferences to suggest a top level from"))))))
2081 ((not (rst-adornment-complete-p ado indent))
2082 ;; Case 2: Incomplete adornment.
2083 ;; Use lax since indentation might not match suggestion.
2084 (rst-Hdr-new-lax ado indent))
2085 ;; Case 3: Complete adornment exists from here on.
2086 (toggle-style
2087 ;; Simply switch the style of the current adornment.
2088 (setq toggle-style nil) ; Remember toggling has been done.
2089 (rst-Hdr-new-invert ado rst-default-indent))
2090 (t
2091 ;; Rotate, ignoring a sole adornment around the current line.
2092 (let ((hier (rst-hdr-hierarchy (point))))
2093 (cond
2094 ;; Next header can be determined from hierarchy or preferences.
2095 ((rst-next-hdr
2096 ;; Use lax since indentation might not match suggestion.
2097 (rst-Hdr-new-lax ado indent) hier prev reverse))
2098 ;; No next header found.
2099 ("No preferences or hierarchy to suggest another level from"))))))
2100 (if (stringp hdr-msg)
2101 (list nil toggle-style hdr-msg)
2102 (list hdr-msg toggle-style)))))
2103
2119(defun rst-adjust-section (toggle-style reverse) 2104(defun rst-adjust-section (toggle-style reverse)
2120"Adjust/rotate the section adornment for the section title around point. 2105 ;; testcover: ok.
2106 "Adjust/rotate the section adornment for the section title around point.
2121The action this function takes depends on context around the 2107The action this function takes depends on context around the
2122point, and it is meant to be invoked possibly more than once to 2108point, and it is meant to be invoked possibly more than once to
2123rotate among the various possibilities. Basically, this function 2109rotate among the various possibilities. Basically, this function
@@ -2191,135 +2177,71 @@ around the cursor. Then the following cases are distinguished.
2191 However, if TOGGLE-STYLE, we do not rotate the adornment, but instead simply 2177 However, if TOGGLE-STYLE, we do not rotate the adornment, but instead simply
2192 toggle the style of the current adornment." 2178 toggle the style of the current adornment."
2193 (rst-reset-section-caches) 2179 (rst-reset-section-caches)
2194 (let ((ttl (rst-ttl-at-point)) 2180 (let ((ttl (rst-ttl-at-point)))
2195 (orig-pnt (point))
2196 msg)
2197 (if (not ttl) 2181 (if (not ttl)
2198 (setq msg '("No section header or candidate at point")) 2182 '("No section header or candidate at point")
2199 (goto-char (rst-Ttl-get-title-beginning ttl)) 2183 (cl-destructuring-bind
2200 (let ((moved (- (line-number-at-pos) (line-number-at-pos orig-pnt))) 2184 (hdr toggle-style &rest msg
2201 (found (rst-Ttl-ado ttl)) 2185 &aux
2202 (indent (rst-Ttl-indent ttl)) 2186 (indent (rst-Ttl-indent ttl))
2203 (prev (rst-get-previous-hdr)) 2187 (moved (- (line-number-at-pos (rst-Ttl-get-title-beginning ttl))
2204 new) 2188 (line-number-at-pos))))
2205 (when (and found (not (rst-Ado-p found))) 2189 (rst-adjust-new-hdr toggle-style reverse ttl)
2206 ;; Normalize found adornment - overline with no underline counts as 2190 (if msg
2207 ;; overline. 2191 msg
2208 (setq found (rst-Ado-new-over-and-under found)))
2209 (setq new
2210 (cond
2211 ((not found)
2212 ;; Case 1: No adornment at all.
2213 (let ((hier (rst-hdr-hierarchy)))
2214 (if prev
2215 ;; Previous header exists - use it.
2216 (cond
2217 ;; Customization and parameters require that the
2218 ;; previous level is used - use it as is.
2219 ((or (and rst-new-adornment-down reverse)
2220 (and (not rst-new-adornment-down) (not reverse)))
2221 prev)
2222 ;; Advance one level down.
2223 ((rst-next-hdr prev hier prev t))
2224 (t
2225 (setq msg '("Neither hierarchy nor preferences can suggest a deeper header"))
2226 nil))
2227 ;; First header in the buffer - use the first adornment
2228 ;; from preferences or hierarchy.
2229 (let ((p (car (rst-Hdr-preferred-adornments)))
2230 (h (car hier)))
2231 (cond
2232 ((if reverse
2233 ;; Prefer hierarchy for downwards
2234 (or h p)
2235 ;; Prefer preferences for upwards
2236 (or p h)))
2237 (t
2238 (setq msg '("No preferences to suggest a top level from"))
2239 nil))))))
2240 ((not (rst-adornment-complete-p found indent))
2241 ;; Case 2: Incomplete adornment.
2242 ;; Use lax since indentation might not match suggestion.
2243 (rst-Hdr-new-lax found indent))
2244 ;; Case 3: Complete adornment exists from here on.
2245 (toggle-style
2246 ;; Simply switch the style of the current adornment.
2247 (setq toggle-style nil) ;; Remember toggling has been done.
2248 (rst-Hdr-new-invert found rst-default-indent))
2249 (t
2250 ;; Rotate, ignoring a sole adornment around the current line.
2251 (let ((hier (rst-hdr-hierarchy t)))
2252 (cond
2253 ;; Next header can be determined from hierarchy or
2254 ;; preferences.
2255 ((rst-next-hdr
2256 ;; Use lax since indentation might not match suggestion.
2257 (rst-Hdr-new-lax found indent) hier prev reverse))
2258 ;; No next header found.
2259 (t
2260 (setq msg '("No preferences or hierarchy to suggest another level from"))
2261 nil))))))
2262 (if (not new)
2263 (goto-char orig-pnt)
2264 (when toggle-style 2192 (when toggle-style
2265 (setq new (rst-Hdr-new-invert (rst-Hdr-ado new) indent))) 2193 (setq hdr (rst-Hdr-new-invert (rst-Hdr-ado hdr) indent)))
2266 ;; Override indent with present indent if there is some. 2194 ;; Override indent with present indent if there is some.
2267 (when (> indent 0) 2195 (when (> indent 0)
2268 ;; Use lax since existing indent may not be valid for new style. 2196 ;; Use lax since existing indent may not be valid for new style.
2269 (setq new (rst-Hdr-new-lax (rst-Hdr-ado new) indent))) 2197 (setq hdr (rst-Hdr-new-lax (rst-Hdr-ado hdr) indent)))
2270 (rst-update-section new) 2198 (goto-char (rst-Ttl-get-title-beginning ttl))
2271 ;; Correct the position of the cursor to more accurately reflect where 2199 (rst-update-section hdr)
2272 ;; it was located when the function was invoked. 2200 ;; Correct the position of the cursor to more accurately reflect
2201 ;; where it was located when the function was invoked.
2273 (unless (zerop moved) 2202 (unless (zerop moved)
2274 (forward-line (- moved)) 2203 (1value ; No lines may be left to move.
2275 (end-of-line))))) 2204 (rst-forward-line-strict (- moved)))
2276 msg)) 2205 (end-of-line))
2206 nil)))))
2277 2207
2278;; Maintain an alias for compatibility. 2208;; Maintain an alias for compatibility.
2279(defalias 'rst-adjust-section-title 'rst-adjust) 2209(defalias 'rst-adjust-section-title 'rst-adjust)
2280 2210
2281(defun rst-promote-region (demote) 2211(defun rst-adjust-region (demote)
2212 ;; testcover: ok.
2282 "Promote the section titles within the region. 2213 "Promote the section titles within the region.
2283With argument DEMOTE or a prefix argument, demote the section 2214With argument DEMOTE or a prefix argument, demote the section
2284titles instead. The algorithm used at the boundaries of the 2215titles instead. The algorithm used at the boundaries of the
2285hierarchy is similar to that used by `rst-adjust-section'." 2216hierarchy is similar to that used by `rst-adjust-section'."
2286 (interactive "P") 2217 (interactive "P")
2287 (rst-reset-section-caches) 2218 (rst-reset-section-caches)
2288 (let ((ttls (rst-all-ttls)) 2219 (let* ((beg (region-beginning))
2289 (hier (rst-hdr-hierarchy)) 2220 (end (region-end))
2290 (region-beg (save-excursion 2221 (ttls-reg (cl-remove-if-not
2291 (goto-char (region-beginning)) 2222 #'(lambda (ttl)
2292 (line-beginning-position))) 2223 (and
2293 (region-end (save-excursion 2224 (>= (rst-Ttl-contains ttl beg) 0)
2294 (goto-char (region-end)) 2225 (< (rst-Ttl-contains ttl end) 0)))
2295 (line-beginning-position))) 2226 (rst-all-ttls))))
2296 marker-list)
2297
2298 ;; Skip the markers that come before the region beginning.
2299 (while (and ttls (< (rst-Ttl-get-title-beginning (car ttls)) region-beg))
2300 (setq ttls (cdr ttls)))
2301
2302 ;; Create a list of markers for all the adornments which are found within
2303 ;; the region.
2304 (save-excursion 2227 (save-excursion
2305 (while (and ttls (< (rst-Ttl-get-title-beginning (car ttls)) region-end))
2306 (push (cons (copy-marker (rst-Ttl-get-title-beginning (car ttls)))
2307 (rst-Ttl-hdr (car ttls))) marker-list)
2308 (setq ttls (cdr ttls)))
2309
2310 ;; Apply modifications. 2228 ;; Apply modifications.
2311 (dolist (p marker-list) 2229 (rst-destructuring-dolist
2312 ;; Go to the adornment to promote. 2230 ((marker &rest hdr
2313 (goto-char (car p)) 2231 &aux (hier (rst-hdr-hierarchy)))
2232 (mapcar #'(lambda (ttl)
2233 (cons (copy-marker (rst-Ttl-get-title-beginning ttl))
2234 (rst-Ttl-hdr ttl)))
2235 ttls-reg))
2236 (set-marker
2237 (goto-char marker) nil)
2314 ;; `rst-next-hdr' cannot return nil because we apply to a section 2238 ;; `rst-next-hdr' cannot return nil because we apply to a section
2315 ;; header so there is some hierarchy. 2239 ;; header so there is some hierarchy.
2316 (rst-update-section (rst-next-hdr (cdr p) hier nil demote)) 2240 (rst-update-section (rst-next-hdr hdr hier nil demote)))
2317
2318 ;; Clear marker to avoid slowing down the editing after we're done.
2319 (set-marker (car p) nil))
2320 (setq deactivate-mark nil)))) 2241 (setq deactivate-mark nil))))
2321 2242
2322(defun rst-display-hdr-hierarchy () 2243(defun rst-display-hdr-hierarchy ()
2244 ;; testcover: ok.
2323 "Display the current file's section title adornments hierarchy. 2245 "Display the current file's section title adornments hierarchy.
2324Hierarchy is displayed in a temporary buffer." 2246Hierarchy is displayed in a temporary buffer."
2325 (interactive) 2247 (interactive)
@@ -2333,7 +2255,7 @@ Hierarchy is displayed in a temporary buffer."
2333 (rst-update-section hdr) 2255 (rst-update-section hdr)
2334 (goto-char (point-max)) 2256 (goto-char (point-max))
2335 (insert "\n") 2257 (insert "\n")
2336 (incf level)))))) 2258 (cl-incf level))))))
2337 2259
2338;; Maintain an alias for backward compatibility. 2260;; Maintain an alias for backward compatibility.
2339(defalias 'rst-display-adornments-hierarchy 'rst-display-hdr-hierarchy) 2261(defalias 'rst-display-adornments-hierarchy 'rst-display-hdr-hierarchy)
@@ -2341,6 +2263,7 @@ Hierarchy is displayed in a temporary buffer."
2341;; FIXME: Should accept an argument giving the hierarchy level to start with 2263;; FIXME: Should accept an argument giving the hierarchy level to start with
2342;; instead of the top of the hierarchy. 2264;; instead of the top of the hierarchy.
2343(defun rst-straighten-sections () 2265(defun rst-straighten-sections ()
2266 ;; testcover: ok.
2344 "Redo the adornments of all section titles in the current buffer. 2267 "Redo the adornments of all section titles in the current buffer.
2345This is done using the preferred set of adornments. This can be 2268This is done using the preferred set of adornments. This can be
2346used, for example, when using somebody else's copy of a document, 2269used, for example, when using somebody else's copy of a document,
@@ -2348,17 +2271,17 @@ in order to adapt it to our preferred style."
2348 (interactive) 2271 (interactive)
2349 (rst-reset-section-caches) 2272 (rst-reset-section-caches)
2350 (save-excursion 2273 (save-excursion
2351 (dolist (ttl-marker (mapcar 2274 (rst-destructuring-dolist
2352 (lambda (ttl) 2275 ((marker &rest level)
2353 (cons ttl (copy-marker 2276 (mapcar
2354 (rst-Ttl-get-title-beginning ttl)))) 2277 (cl-function
2355 (rst-all-ttls-with-level))) 2278 (lambda ((ttl &rest level))
2356 ;; Go to the appropriate position. 2279 ;; Use markers so edits don't disturb the position.
2357 (goto-char (cdr ttl-marker)) 2280 (cons (copy-marker (rst-Ttl-get-title-beginning ttl)) level)))
2358 (rst-update-section (nth (rst-Ttl-level (car ttl-marker)) 2281 (rst-all-ttls-with-level)))
2359 (rst-Hdr-preferred-adornments))) 2282 (set-marker
2360 ;; Reset the marker to avoid slowing down editing. 2283 (goto-char marker) nil)
2361 (set-marker (cdr ttl-marker) nil)))) 2284 (rst-update-section (nth level (rst-Hdr-preferred-adornments))))))
2362 2285
2363;; Maintain an alias for compatibility. 2286;; Maintain an alias for compatibility.
2364(defalias 'rst-straighten-adornments 'rst-straighten-sections) 2287(defalias 'rst-straighten-adornments 'rst-straighten-sections)
@@ -2367,9 +2290,9 @@ in order to adapt it to our preferred style."
2367;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2290;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2368;; Insert list items 2291;; Insert list items
2369 2292
2370; Borrowed from a2r.el (version 1.3), by Lawrence Mitchell <wence@gmx.li>. 2293;; Borrowed from a2r.el (version 1.3), by Lawrence Mitchell <wence@gmx.li>. I
2371; I needed to make some tiny changes to the functions, so I put it here. 2294;; needed to make some tiny changes to the functions, so I put it here.
2372; -- Wei-Wei Guo 2295;; -- Wei-Wei Guo
2373 2296
2374(defconst rst-arabic-to-roman 2297(defconst rst-arabic-to-roman
2375 '((1000 . "M") (900 . "CM") (500 . "D") (400 . "CD") 2298 '((1000 . "M") (900 . "CM") (500 . "D") (400 . "CD")
@@ -2378,73 +2301,59 @@ in order to adapt it to our preferred style."
2378 (1 . "I")) 2301 (1 . "I"))
2379 "List of maps between Arabic numbers and their Roman numeral equivalents.") 2302 "List of maps between Arabic numbers and their Roman numeral equivalents.")
2380 2303
2381(defun rst-arabic-to-roman (num &optional arg) 2304(defun rst-arabic-to-roman (num)
2305 ;; testcover: ok.
2382 "Convert Arabic number NUM to its Roman numeral representation. 2306 "Convert Arabic number NUM to its Roman numeral representation.
2383 2307
2384Obviously, NUM must be greater than zero. Don't blame me, blame the 2308Obviously, NUM must be greater than zero. Don't blame me, blame the
2385Romans, I mean \"what have the Romans ever _done_ for /us/?\" (with 2309Romans, I mean \"what have the Romans ever _done_ for /us/?\" (with
2386apologies to Monty Python). 2310apologies to Monty Python)."
2387If optional ARG is non-nil, insert in current buffer." 2311 (cl-check-type num (integer 1 *))
2388 (let ((map rst-arabic-to-roman) 2312 (let ((map rst-arabic-to-roman)
2389 res) 2313 (r ""))
2390 (while (and map (> num 0)) 2314 (while (and map (> num 0))
2391 (if (or (= num (caar map)) 2315 (cl-destructuring-bind ((val &rest sym) &rest next) map
2392 (> num (caar map))) 2316 (if (>= num val)
2393 (setq res (concat res (cdar map)) 2317 (setq r (concat r sym)
2394 num (- num (caar map))) 2318 num (- num val))
2395 (setq map (cdr map)))) 2319 (setq map next))))
2396 (if arg (insert (or res "")) res))) 2320 r))
2397 2321
2398(defun rst-roman-to-arabic (string &optional arg) 2322(defun rst-roman-to-arabic (string)
2323 ;; testcover: ok.
2399 "Convert STRING of Roman numerals to an Arabic number. 2324 "Convert STRING of Roman numerals to an Arabic number.
2400
2401If STRING contains a letter which isn't a valid Roman numeral, 2325If STRING contains a letter which isn't a valid Roman numeral,
2402the rest of the string from that point onwards is ignored. 2326the rest of the string from that point onwards is ignored.
2403
2404Hence: 2327Hence:
2405MMD == 2500 2328MMD == 2500
2406and 2329and
2407MMDFLXXVI == 2500. 2330MMDFLXXVI == 2500."
2408If optional ARG is non-nil, insert in current buffer." 2331 (cl-check-type string string)
2332 (cl-check-type string (satisfies (lambda (s)
2333 (not (equal s ""))))
2334 "Roman number may not be an empty string.")
2409 (let ((res 0) 2335 (let ((res 0)
2410 (map rst-arabic-to-roman)) 2336 (map rst-arabic-to-roman))
2411 (while map 2337 (save-match-data
2412 (if (string-match (concat "^" (cdar map)) string) 2338 (while map
2413 (setq res (+ res (caar map)) 2339 (cl-destructuring-bind ((val &rest sym) &rest next) map
2414 string (replace-match "" nil t string)) 2340 (if (string-match (concat "^" sym) string)
2415 (setq map (cdr map)))) 2341 (setq res (+ res val)
2416 (if arg (insert res) res))) 2342 string (replace-match "" nil t string))
2343 (setq map next))))
2344 (cl-check-type string (satisfies (lambda (s)
2345 (equal s "")))
2346 "Invalid characters in roman number")
2347 res)))
2417 2348
2418;; End of borrow. 2349;; End of borrow.
2419 2350
2420(defun rst-find-pfx-in-region (beg end pfx-re) 2351;; FIXME: All the following code should not consider single lines as items but
2421 "Find all the positions of prefixes in region between BEG and END. 2352;; paragraphs as reST does.
2422This is used to find bullets and enumerated list items. PFX-RE is 2353
2423a regular expression for matching the lines after indentation 2354(defun rst-insert-list-new-tag (tag)
2424with items. Returns a list of cons cells consisting of the point 2355 ;; testcover: ok.
2425and the column of the point." 2356 "Insert first item of a new list tagged with TAG.
2426 (let ((pfx ()))
2427 (save-excursion
2428 (goto-char beg)
2429 (while (< (point) end)
2430 (back-to-indentation)
2431 (when (and
2432 (looking-at pfx-re) ; pfx found and...
2433 (let ((pfx-col (current-column)))
2434 (save-excursion
2435 (forward-line -1) ; ...previous line is...
2436 (back-to-indentation)
2437 (or (looking-at (rst-re 'lin-end)) ; ...empty,
2438 (> (current-column) pfx-col) ; ...deeper level, or
2439 (and (= (current-column) pfx-col)
2440 (looking-at pfx-re)))))) ; ...pfx at same level.
2441 (push (cons (point) (current-column))
2442 pfx))
2443 (forward-line 1)))
2444 (nreverse pfx)))
2445
2446(defun rst-insert-list-pos (newitem)
2447 "Arrange relative position of a newly inserted list item of style NEWITEM.
2448 2357
2449Adding a new list might consider three situations: 2358Adding a new list might consider three situations:
2450 2359
@@ -2460,45 +2369,42 @@ When not (a), first forward point to the end of the line, and add two
2460blank lines, then add the new list. 2369blank lines, then add the new list.
2461 2370
2462Other situations are just ignored and left to users themselves." 2371Other situations are just ignored and left to users themselves."
2463 (if (save-excursion 2372 ;; FIXME: Following line is not considered at all.
2464 (beginning-of-line) 2373 (let ((pfx-nls
2465 (looking-at (rst-re 'lin-end))) 2374 ;; FIXME: Doesn't work properly for white-space line. See
2466 (if (save-excursion 2375 ;; `rst-insert-list-new-BUGS'.
2467 (forward-line -1) 2376 (if (rst-forward-line-looking-at 0 'lin-end)
2468 (looking-at (rst-re 'lin-end))) 2377 (if (not (rst-forward-line-looking-at -1 'lin-end #'not))
2469 (insert newitem " ") 2378 0
2470 (insert "\n" newitem " ")) 2379 1)
2380 2)))
2471 (end-of-line) 2381 (end-of-line)
2472 (insert "\n\n" newitem " "))) 2382 ;; FIXME: The indentation is not fixed to a single space by the syntax. May
2473 2383 ;; be this should be configurable or rather taken from the context.
2474;; FIXME: Isn't this a `defconst'? 2384 (insert (make-string pfx-nls ?\n) tag " ")))
2475(defvar rst-initial-enums 2385
2476 (let (vals) 2386(defconst rst-initial-items
2477 (dolist (fmt '("%s." "(%s)" "%s)")) 2387 (append (mapcar #'char-to-string rst-bullets)
2478 (dolist (c '("1" "a" "A" "I" "i")) 2388 (let (vals)
2479 (push (format fmt c) vals))) 2389 (dolist (fmt '("%s." "(%s)" "%s)"))
2480 (cons "#." (nreverse vals))) 2390 (dolist (c '("#" "1" "a" "A" "I" "i"))
2481 "List of initial enumerations.") 2391 (push (format fmt c) vals)))
2482 2392 (nreverse vals)))
2483;; FIXME: Isn't this a `defconst'?
2484(defvar rst-initial-items
2485 (append (mapcar 'char-to-string rst-bullets) rst-initial-enums)
2486 "List of initial items. It's a collection of bullets and enumerations.") 2393 "List of initial items. It's a collection of bullets and enumerations.")
2487 2394
2488(defun rst-insert-list-new-item () 2395(defun rst-insert-list-new-item ()
2396 ;; testcover: ok.
2489 "Insert a new list item. 2397 "Insert a new list item.
2490 2398
2491User is asked to select the item style first, for example (a), i), +. 2399User is asked to select the item style first, for example (a), i), +.
2492Use TAB for completion and choices. 2400Use TAB for completion and choices.
2493 2401
2494If user selects bullets or #, it's just added with position arranged by 2402If user selects bullets or #, it's just added with position arranged by
2495`rst-insert-list-pos'. 2403`rst-insert-list-new-tag'.
2496 2404
2497If user selects enumerations, a further prompt is given. User need to 2405If user selects enumerations, a further prompt is given. User need to
2498input a starting item, for example 'e' for 'A)' style. The position is 2406input a starting item, for example 'e' for 'A)' style. The position is
2499also arranged by `rst-insert-list-pos'." 2407also arranged by `rst-insert-list-new-tag'."
2500 (interactive)
2501 ;; FIXME: Make this comply to `interactive' standards.
2502 (let* ((itemstyle (completing-read 2408 (let* ((itemstyle (completing-read
2503 "Select preferred item style [#.]: " 2409 "Select preferred item style [#.]: "
2504 rst-initial-items nil t nil nil "#.")) 2410 rst-initial-items nil t nil nil "#."))
@@ -2506,7 +2412,6 @@ also arranged by `rst-insert-list-pos'."
2506 (match-string 0 itemstyle))) 2412 (match-string 0 itemstyle)))
2507 (no 2413 (no
2508 (save-match-data 2414 (save-match-data
2509 ;; FIXME: Make this comply to `interactive' standards.
2510 (cond 2415 (cond
2511 ((equal cnt "a") 2416 ((equal cnt "a")
2512 (let ((itemno (read-string "Give starting value [a]: " 2417 (let ((itemno (read-string "Give starting value [a]: "
@@ -2527,66 +2432,73 @@ also arranged by `rst-insert-list-pos'."
2527 (number-to-string itemno))))))) 2432 (number-to-string itemno)))))))
2528 (if no 2433 (if no
2529 (setq itemstyle (replace-match no t t itemstyle))) 2434 (setq itemstyle (replace-match no t t itemstyle)))
2530 (rst-insert-list-pos itemstyle))) 2435 (rst-insert-list-new-tag itemstyle)))
2531 2436
2532(defcustom rst-preferred-bullets 2437(defcustom rst-preferred-bullets
2533 '(?* ?- ?+) 2438 '(?* ?- ?+)
2534 "List of favorite bullets." 2439 "List of favorite bullets."
2535 :group 'rst 2440 :group 'rst
2536 :type `(repeat 2441 :type `(repeat
2537 (choice ,@(mapcar (lambda (char) 2442 (choice ,@(mapcar #'(lambda (char)
2538 (list 'const 2443 (list 'const
2539 :tag (char-to-string char) char)) 2444 :tag (char-to-string char) char))
2540 rst-bullets))) 2445 rst-bullets)))
2541 :package-version '(rst . "1.1.0")) 2446 :package-version '(rst . "1.1.0"))
2542(rst-testcover-defcustom) 2447(rst-testcover-defcustom)
2543 2448
2544(defun rst-insert-list-continue (curitem prefer-roman) 2449(defun rst-insert-list-continue (ind tag tab prefer-roman)
2545 "Insert a list item with list start CURITEM including its indentation level. 2450 ;; testcover: ok.
2546If PREFER-ROMAN roman numbering is preferred over using letters." 2451 "Insert a new list tag after the current line according to style.
2452Style is defined by indentaton IND, TAG and suffix TAB. If
2453PREFER-ROMAN roman numbering is preferred over using letters."
2547 (end-of-line) 2454 (end-of-line)
2548 (insert 2455 (insert
2549 "\n" ; FIXME: Separating lines must be possible. 2456 ;; FIXME: Separating lines must be possible.
2550 (cond 2457 "\n"
2551 ((string-match (rst-re '(:alt enmaut-tag 2458 ind
2552 bul-tag)) curitem) 2459 (save-match-data
2553 curitem) 2460 (if (not (string-match (rst-re 'cntexp-tag) tag))
2554 ((string-match (rst-re 'num-tag) curitem) 2461 tag
2555 (replace-match (number-to-string 2462 (let ((pfx (substring tag 0 (match-beginning 0)))
2556 (1+ (string-to-number (match-string 0 curitem)))) 2463 (cnt (match-string 0 tag))
2557 nil nil curitem)) 2464 (sfx (substring tag (match-end 0))))
2558 ((and (string-match (rst-re 'rom-tag) curitem) 2465 (concat
2559 (save-match-data 2466 pfx
2560 (if (string-match (rst-re 'ltr-tag) curitem) ; Also a letter tag. 2467 (cond
2561 (save-excursion 2468 ((string-match (rst-re 'num-tag) cnt)
2562 ;; FIXME: Assumes one line list items without separating 2469 (number-to-string (1+ (string-to-number (match-string 0 cnt)))))
2563 ;; empty lines. 2470 ((and
2564 (if (and (zerop (forward-line -1)) 2471 (string-match (rst-re 'rom-tag) cnt)
2565 (looking-at (rst-re 'enmexp-beg))) 2472 (save-match-data
2566 (string-match 2473 (if (string-match (rst-re 'ltr-tag) cnt) ; Also a letter tag.
2567 (rst-re 'rom-tag) 2474 (save-excursion
2568 (match-string 0)) ; Previous was a roman tag. 2475 ;; FIXME: Assumes one line list items without separating
2569 prefer-roman)) ; Don't know - use flag. 2476 ;; empty lines.
2570 t))) ; Not a letter tag. 2477 ;; Use of `rst-forward-line-looking-at' is very difficult
2571 (replace-match 2478 ;; here so don't do it.
2572 (let* ((old (match-string 0 curitem)) 2479 (if (and (rst-forward-line-strict -1)
2573 (new (save-match-data 2480 (looking-at (rst-re 'enmexp-beg)))
2574 (rst-arabic-to-roman 2481 (string-match
2575 (1+ (rst-roman-to-arabic 2482 (rst-re 'rom-tag)
2576 (upcase old))))))) 2483 (match-string 0)) ; Previous was a roman tag.
2577 (if (equal old (upcase old)) 2484 prefer-roman)) ; Don't know - use flag.
2578 (upcase new) 2485 t))) ; Not a letter tag.
2579 (downcase new))) 2486 (let* ((old (match-string 0 cnt))
2580 t nil curitem)) 2487 (new (rst-arabic-to-roman
2581 ((string-match (rst-re 'ltr-tag) curitem) 2488 (1+ (rst-roman-to-arabic (upcase old))))))
2582 (replace-match (char-to-string 2489 (if (equal old (upcase old))
2583 (1+ (string-to-char (match-string 0 curitem)))) 2490 (upcase new)
2584 nil nil curitem))))) 2491 (downcase new))))
2492 ((string-match (rst-re 'ltr-tag) cnt)
2493 (char-to-string (1+ (string-to-char (match-string 0 cnt))))))
2494 sfx))))
2495 tab))
2585 2496
2586;; FIXME: At least the continuation may be folded into 2497;; FIXME: At least the continuation may be folded into
2587;; `newline-and-indent`. However, this may not be wanted by everyone so 2498;; `newline-and-indent`. However, this may not be wanted by everyone so
2588;; it should be possible to switch this off. 2499;; it should be possible to switch this off.
2589(defun rst-insert-list (&optional prefer-roman) 2500(defun rst-insert-list (&optional prefer-roman)
2501 ;; testcover: ok.
2590 "Insert a list item at the current point. 2502 "Insert a list item at the current point.
2591 2503
2592The command can insert a new list or a continuing list. When it is called at a 2504The command can insert a new list or a continuing list. When it is called at a
@@ -2614,84 +2526,135 @@ preceded by a blank line, it is hard to determine which type to use
2614automatically. The function uses alphabetical list by default. If you want 2526automatically. The function uses alphabetical list by default. If you want
2615roman numerical list, just use a prefix to set PREFER-ROMAN." 2527roman numerical list, just use a prefix to set PREFER-ROMAN."
2616 (interactive "P") 2528 (interactive "P")
2617 (beginning-of-line) 2529 (save-match-data
2618 (if (looking-at (rst-re 'itmany-beg-1)) 2530 (1value
2619 (rst-insert-list-continue (match-string 0) prefer-roman) 2531 (rst-forward-line-strict 0))
2620 (rst-insert-list-new-item))) 2532 ;; FIXME: Finds only tags in single line items. Multi-line items should be
2533 ;; considered as well.
2534 ;; Using `rst-forward-line-looking-at' is more complicated so don't do it.
2535 (if (looking-at (rst-re 'itmany-beg-1))
2536 (rst-insert-list-continue
2537 (buffer-substring-no-properties
2538 (match-beginning 0) (match-beginning 1))
2539 (match-string 1)
2540 (buffer-substring-no-properties (match-end 1) (match-end 0))
2541 prefer-roman)
2542 (rst-insert-list-new-item))))
2543
2544;; FIXME: This is wrong because it misses prefixed lines without intervening
2545;; new line. See `rst-straighten-bullets-region-BUGS' and
2546;; `rst-find-begs-BUGS'.
2547(defun rst-find-begs (beg end rst-re-beg)
2548 ;; testcover: ok.
2549 "Return the positions of begs in region BEG to END.
2550RST-RE-BEG is a `rst-re' argument and matched at the beginning of
2551a line. Return a list of (POINT . COLUMN) where POINT gives the
2552point after indentaton and COLUMN gives its column. The list is
2553ordererd by POINT."
2554 (let (r)
2555 (save-match-data
2556 (save-excursion
2557 ;; FIXME refactoring: Consider making this construct a macro looping
2558 ;; over the lines.
2559 (goto-char beg)
2560 (1value
2561 (rst-forward-line-strict 0))
2562 (while (< (point) end)
2563 (let ((clm (current-indentation)))
2564 ;; FIXME refactoring: Consider using `rst-forward-line-looking-at'.
2565 (when (and
2566 (looking-at (rst-re rst-re-beg)) ; Start found
2567 (not (rst-forward-line-looking-at
2568 -1 'lin-end
2569 #'(lambda (mtcd) ; Previous line exists and is...
2570 (and
2571 (not mtcd) ; non-empty,
2572 (<= (current-indentation) clm) ; less indented
2573 (not (and (= (current-indentation) clm)
2574 ; not a beg at same level.
2575 (looking-at (rst-re rst-re-beg)))))))))
2576 (back-to-indentation)
2577 (push (cons (point) clm) r)))
2578 (1value ; At least one line is moved in this loop.
2579 (rst-forward-line-strict 1 end)))))
2580 (nreverse r)))
2621 2581
2622(defun rst-straighten-bullets-region (beg end) 2582(defun rst-straighten-bullets-region (beg end)
2623 "Make all the bulleted list items in the region consistent. 2583 ;; testcover: ok.
2624The region is specified between BEG and END. You can use this 2584 "Make all the bulleted list items in the region from BEG to END consistent.
2625after you have merged multiple bulleted lists to make them use 2585Use this after you have merged multiple bulleted lists to make
2626the same/correct/consistent bullet characters. 2586them use the preferred bullet characters given by
2627 2587`rst-preferred-bullets' for each level. If bullets are found on
2628See variable `rst-preferred-bullets' for the list of bullets to 2588levels beyond the `rst-preferred-bullets' list, they are not
2629adjust. If bullets are found on levels beyond the 2589modified."
2630`rst-preferred-bullets' list, they are not modified."
2631 (interactive "r") 2590 (interactive "r")
2632 2591 (save-excursion
2633 (let ((bullets (rst-find-pfx-in-region beg end (rst-re 'bul-sta))) 2592 (let (clm2pnts) ; Map a column to a list of points at this column.
2634 (levtable (make-hash-table :size 4))) 2593 (rst-destructuring-dolist
2635 2594 ((point &rest column
2636 ;; Create a map of levels to list of positions. 2595 &aux (found (assoc column clm2pnts)))
2637 (dolist (x bullets) 2596 (rst-find-begs beg end 'bul-beg))
2638 (let ((key (cdr x))) 2597 (if found
2639 (puthash key 2598 ;;; (push point (cdr found)) ; FIXME: Doesn't work with `testcover'.
2640 (append (gethash key levtable (list)) 2599 (setcdr found (cons point (cdr found))) ; Synonym.
2641 (list (car x))) 2600 (push (list column point) clm2pnts)))
2642 levtable))) 2601 (rst-destructuring-dolist
2643 2602 ((bullet _clm &rest pnts)
2644 ;; Sort this map and create a new map of prefix char and list of positions. 2603 ;; Zip preferred bullets and sorted columns associating a bullet
2645 (let ((poslist ())) ; List of (indent . positions). 2604 ;; with a column and all the points this column is found.
2646 (maphash (lambda (x y) (push (cons x y) poslist)) levtable) 2605 (cl-mapcar #'(lambda (bullet clm2pnt)
2647 2606 (cons bullet clm2pnt))
2648 (let ((bullets rst-preferred-bullets)) 2607 rst-preferred-bullets
2649 (dolist (x (sort poslist 'car-less-than-car)) 2608 (sort clm2pnts #'car-less-than-car)))
2650 (when bullets 2609 ;; Replace the bullets by the preferred ones.
2651 ;; Apply the characters. 2610 (dolist (pnt pnts)
2652 (dolist (pos (cdr x)) 2611 (goto-char pnt)
2653 (goto-char pos) 2612 ;; FIXME: Assumes bullet to replace is a single char.
2654 (delete-char 1) 2613 (delete-char 1)
2655 (insert (string (car bullets)))) 2614 (insert bullet))))))
2656 (setq bullets (cdr bullets))))))))
2657 2615
2658 2616
2659;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2617;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2660;; Table of contents 2618;; Table of contents
2661 2619
2662(defun rst-all-stn () 2620(defun rst-all-stn ()
2663 "Return the hierarchical tree of section titles as a top level `rst-Stn'. 2621 ;; testcover: ok.
2664Return nil for no section titles." 2622 "Return the hierarchical tree of sections as a top level `rst-Stn'.
2665 ;; FIXME: The top level node may contain the document title instead of nil. 2623Return value satisfies `rst-Stn-is-top' or is nil for no
2624sections."
2666 (cdr (rst-remaining-stn (rst-all-ttls-with-level) -1))) 2625 (cdr (rst-remaining-stn (rst-all-ttls-with-level) -1)))
2667 2626
2668(defun rst-remaining-stn (remaining lev) 2627(defun rst-remaining-stn (unprocessed expected)
2669 "Process the first entry of REMAINING expected to be on level LEV. 2628 ;; testcover: ok.
2670REMAINING is the remaining list of `rst-Ttl' entries. 2629 "Process the first entry of UNPROCESSED expected to be on level EXPECTED.
2671Return (UNPROCESSED . NODE) for the first entry of REMAINING. 2630UNPROCESSED is the remaining list of (`rst-Ttl' . LEVEL) entries.
2672UNPROCESSED is the list of still unprocessed entries. NODE is a 2631Return (REMAINING . STN) for the first entry of UNPROCESSED.
2673`rst-Stn' or nil if REMAINING is empty." 2632REMAINING is the list of still unprocessed entries. STN is a
2674 (let ((ttl (car remaining)) 2633`rst-Stn' or nil if UNPROCESSED is empty."
2675 (unprocessed remaining) 2634 (if (not unprocessed)
2676 fnd children) 2635 (1value
2677 ;; If the current adornment matches expected level. 2636 (cons nil nil))
2678 (when (and ttl (= (rst-Ttl-level ttl) lev)) 2637 (cl-destructuring-bind
2679 ;; Consume the current entry and create the current node with it. 2638 ((ttl &rest level) &rest next
2680 (setq unprocessed (cdr remaining)) 2639 &aux fnd children)
2681 (setq fnd ttl)) 2640 unprocessed
2682 ;; Build the child nodes as long as they have deeper level. 2641 (when (= level expected)
2683 (while (and unprocessed (> (rst-Ttl-level (car unprocessed)) lev)) 2642 ;; Consume the current entry and create the current node with it.
2684 (let* ((rem-child (rst-remaining-stn unprocessed (1+ lev))) 2643 (setq fnd ttl)
2685 (child (cdr rem-child))) 2644 (setq unprocessed next))
2686 (when child 2645 ;; Build the child nodes as long as they have deeper level.
2687 (push child children)) 2646 (while (and unprocessed (> (cdar unprocessed) expected))
2688 (setq unprocessed (car rem-child)))) 2647 (cl-destructuring-bind (remaining &rest stn)
2689 (setq children (reverse children)) 2648 (rst-remaining-stn unprocessed (1+ expected))
2690 (cons unprocessed 2649 (when stn
2691 (if (or fnd children) 2650 (push stn children))
2692 (rst-Stn-new fnd lev children))))) 2651 (setq unprocessed remaining)))
2652 (cons unprocessed
2653 (when (or fnd children)
2654 (rst-Stn-new fnd expected (nreverse children)))))))
2693 2655
2694(defun rst-stn-containing-point (stn &optional point) 2656(defun rst-stn-containing-point (stn &optional point)
2657 ;; testcover: ok.
2695 "Return `rst-Stn' in STN before POINT or nil if in no section. 2658 "Return `rst-Stn' in STN before POINT or nil if in no section.
2696POINT defaults to the current point. STN may be nil for no 2659POINT defaults to the current point. STN may be nil for no
2697section headers at all." 2660section headers at all."
@@ -2699,15 +2662,13 @@ section headers at all."
2699 (setq point (or point (point))) 2662 (setq point (or point (point)))
2700 (when (>= point (rst-Stn-get-title-beginning stn)) 2663 (when (>= point (rst-Stn-get-title-beginning stn))
2701 ;; Point may be in this section or a child. 2664 ;; Point may be in this section or a child.
2702 (let ((children (rst-Stn-children stn)) 2665 (let ((in-child (cl-find-if
2703 found) 2666 #'(lambda (child)
2704 (while (and children 2667 (>= point (rst-Stn-get-title-beginning child)))
2705 (>= point (rst-Stn-get-title-beginning (car children)))) 2668 (rst-Stn-children stn)
2706 ;; Point may be in this child. 2669 :from-end t)))
2707 (setq found (car children) 2670 (if in-child
2708 children (cdr children))) 2671 (rst-stn-containing-point in-child point)
2709 (if found
2710 (rst-stn-containing-point found point)
2711 stn))))) 2672 stn)))))
2712 2673
2713(defgroup rst-toc nil 2674(defgroup rst-toc nil
@@ -2729,7 +2690,7 @@ indentation style:
2729- `plain': no numbering (fixed indentation) 2690- `plain': no numbering (fixed indentation)
2730- `fixed': numbering, but fixed indentation 2691- `fixed': numbering, but fixed indentation
2731- `aligned': numbering, titles aligned under each other 2692- `aligned': numbering, titles aligned under each other
2732- `listed': numbering, with dashes like list items (EXPERIMENTAL)" 2693- `listed': titles as list items"
2733 :type '(choice (const plain) 2694 :type '(choice (const plain)
2734 (const fixed) 2695 (const fixed)
2735 (const aligned) 2696 (const aligned)
@@ -2743,143 +2704,204 @@ indentation style:
2743 :group 'rst-toc) 2704 :group 'rst-toc)
2744(rst-testcover-defcustom) 2705(rst-testcover-defcustom)
2745 2706
2746;; FIXME: What does this mean?
2747;; This is used to avoid having to change the user's mode.
2748(defvar rst-toc-insert-click-keymap
2749 (let ((map (make-sparse-keymap)))
2750 (define-key map [mouse-1] 'rst-toc-mode-mouse-goto)
2751 map)
2752 "(Internal) What happens when you click on propertized text in the TOC.")
2753
2754(defcustom rst-toc-insert-max-level nil 2707(defcustom rst-toc-insert-max-level nil
2755 "If non-nil, maximum depth of the inserted TOC." 2708 "If non-nil, maximum depth of the inserted TOC."
2756 :type '(choice (const nil) integer) 2709 :type '(choice (const nil) integer)
2757 :group 'rst-toc) 2710 :group 'rst-toc)
2758(rst-testcover-defcustom) 2711(rst-testcover-defcustom)
2759 2712
2760(defun rst-toc-insert (&optional pfxarg) 2713(defun rst-toc-insert (&optional max-level)
2761 "Insert a text rendering of the table of contents of the current section. 2714 ;; testcover: ok.
2715 "Insert the table of contents of the current section at the current column.
2762By default the top level is ignored if there is only one, because 2716By default the top level is ignored if there is only one, because
2763we assume that the document will have a single title. 2717we assume that the document will have a single title. A numeric
2764 2718prefix argument MAX-LEVEL overrides `rst-toc-insert-max-level'.
2765If a numeric prefix argument PFXARG is given, insert the TOC up 2719Text in the line beyond column is deleted."
2766to the specified level.
2767
2768The TOC is inserted indented at the current column."
2769 (interactive "P") 2720 (interactive "P")
2770 (rst-reset-section-caches) 2721 (rst-reset-section-caches)
2771 (let (;; Check maximum level override. 2722 (let ((pt-stn (rst-stn-containing-point (rst-all-stn))))
2772 (rst-toc-insert-max-level 2723 (when pt-stn
2773 (if (and (integerp pfxarg) (> (prefix-numeric-value pfxarg) 0)) 2724 (let ((max
2774 (prefix-numeric-value pfxarg) rst-toc-insert-max-level)) 2725 (if (and (integerp max-level)
2775 (pt-stn (rst-stn-containing-point (rst-all-stn))) 2726 (> (prefix-numeric-value max-level) 0))
2776 ;; Figure out initial indent. 2727 (prefix-numeric-value max-level)
2777 (initial-indent (make-string (current-column) ? )) 2728 rst-toc-insert-max-level))
2778 (init-point (point))) 2729 (ind (current-column))
2779 (when (and pt-stn (rst-Stn-children pt-stn)) 2730 (buf (current-buffer))
2780 (rst-toc-insert-node pt-stn 0 initial-indent "") 2731 (tabs indent-tabs-mode) ; Copy buffer local value.
2781 ;; FIXME: Really having the last newline would be better. 2732 txt)
2782 ;; Delete the last newline added. 2733 (setq txt
2783 (delete-char -1)))) 2734 ;; Render to temporary buffer so markers are created correctly.
2784 2735 (with-temp-buffer
2785(defun rst-toc-insert-node (stn level indent pfx) 2736 (rst-toc-insert-tree pt-stn buf rst-toc-insert-style max
2786 "Insert STN in table-of-contents. 2737 rst-toc-link-keymap nil)
2787LEVEL is the depth level of the sections in the tree currently 2738 (goto-char (point-min))
2788rendered. INDENT is the indentation string. PFX is the prefix 2739 (when (rst-forward-line-strict 1)
2789numbering, that includes the alignment necessary for all the 2740 ;; There are lines to indent.
2790children of level to align." 2741 (let ((indent-tabs-mode tabs))
2791 ;; Note: we do child numbering from the parent, so we start number the 2742 (indent-rigidly (point) (point-max) ind)))
2792 ;; children one level before we print them. 2743 (buffer-string)))
2793 (when (> level 0) 2744 (unless (zerop (length txt))
2794 (unless (> (current-column) 0) 2745 ;; Delete possible trailing text.
2795 ;; No indent yet - insert it. 2746 (delete-region (point) (line-beginning-position 2))
2796 (insert indent)) 2747 (insert txt)
2797 (let ((beg (point))) 2748 (backward-char 1))))))
2798 (unless (equal rst-toc-insert-style 'plain) 2749
2799 (insert pfx rst-toc-insert-number-separator)) 2750(defun rst-toc-insert-link (pfx stn buf keymap)
2800 (insert (rst-Stn-get-text stn)) 2751 ;; testcover: ok.
2801 ;; Add properties to the text, even though in normal text mode it 2752 "Insert text of STN in BUF as a linked section reference at point.
2802 ;; won't be doing anything for now. Not sure that I want to change 2753If KEYMAP use this as keymap property. PFX is inserted before text."
2803 ;; mode stuff. At least the highlighting gives the idea that this 2754 (let ((beg (point)))
2804 ;; is generated automatically. 2755 (insert pfx)
2805 (put-text-property beg (point) 'mouse-face 'highlight) 2756 (insert (rst-Stn-get-text stn))
2806 (put-text-property 2757 (put-text-property beg (point) 'mouse-face 'highlight)
2807 beg (point) 'rst-toc-target
2808 (set-marker (make-marker) (rst-Stn-get-title-beginning stn)))
2809 (put-text-property beg (point) 'keymap rst-toc-insert-click-keymap))
2810 (insert "\n") 2758 (insert "\n")
2811 ;; Prepare indent for children. 2759 (put-text-property
2812 (setq indent 2760 beg (point) 'rst-toc-target
2813 (cond 2761 (set-marker (make-marker) (rst-Stn-get-title-beginning stn) buf))
2814 ((eq rst-toc-insert-style 'plain) 2762 (when keymap
2815 (concat indent (make-string rst-toc-indent ? ))) 2763 (put-text-property beg (point) 'keymap keymap))))
2816 ((eq rst-toc-insert-style 'fixed) 2764
2817 (concat indent (make-string rst-toc-indent ? ))) 2765(defun rst-toc-get-link (link-buf link-pnt)
2818 ((eq rst-toc-insert-style 'aligned) 2766 ;; testcover: ok.
2819 (concat indent (make-string (+ (length pfx) 2) ? ))) 2767 "Return the link from text property at LINK-PNT in LINK-BUF."
2820 ((eq rst-toc-insert-style 'listed) 2768 (let ((mrkr (get-text-property link-pnt 'rst-toc-target link-buf)))
2821 (concat (substring indent 0 -3) 2769 (unless mrkr
2822 (concat (make-string (+ (length pfx) 2) ? ) " - ")))))) 2770 (error "No section on this line"))
2823 (when (or (eq rst-toc-insert-max-level nil) 2771 (unless (buffer-live-p (marker-buffer mrkr))
2824 (< level rst-toc-insert-max-level)) 2772 (error "Buffer for this section was killed"))
2825 (let ((count 1) 2773 mrkr))
2826 fmt) 2774
2827 ;; Add a separating dot if there is already a prefix. 2775(defconst rst-toc-link-keymap
2828 (when (> (length pfx) 0) 2776 (let ((map (make-sparse-keymap)))
2829 (string-match (rst-re "[ \t\n]*\\'") pfx) 2777 (define-key map [mouse-1] 'rst-toc-mouse-follow-link)
2830 (setq pfx (concat (replace-match "" t t pfx) "."))) 2778 map)
2831 ;; Calculate the amount of space that the prefix will require 2779 "Keymap used for links in TOC.")
2832 ;; for the numbers. 2780
2833 (when (rst-Stn-children stn) 2781(defun rst-toc-insert-tree (stn buf style depth keymap tgt-stn)
2834 (setq fmt 2782 ;; testcover: ok.
2835 (format "%%-%dd" 2783 "Insert table of contents of tree below top node STN in buffer BUF.
2836 (1+ (floor (log (length (rst-Stn-children stn)) 2784STYLE is the style to use and must be one of the symbols allowed
2837 10)))))) 2785for `rst-toc-insert-style'. DEPTH is the maximum relative depth
2838 (dolist (child (rst-Stn-children stn)) 2786from STN to insert or nil for no maximum depth. See
2839 (rst-toc-insert-node child (1+ level) indent 2787`rst-toc-insert-link' for KEYMAP. Return beginning of title line
2840 (concat pfx (format fmt count))) 2788if TGT-STN is rendered or nil if not rendered or TGT-STN is nil.
2841 (incf count))))) 2789Just return nil if STN is nil."
2790 (when stn
2791 (rst-toc-insert-children (rst-Stn-children stn) buf style depth 0 "" keymap
2792 tgt-stn)))
2793
2794(defun rst-toc-insert-children (children buf style depth indent numbering
2795 keymap tgt-stn)
2796 ;; testcover: ok.
2797 "In the current buffer at point insert CHILDREN in BUF to table of contents.
2798See `rst-toc-insert-tree' for STYLE, DEPTH and TGT-STN. See
2799`rst-toc-insert-stn' for INDENT and NUMBERING. See
2800`rst-toc-insert-link' for KEYMAP."
2801 (let ((count 1)
2802 ;; Child numbering is done from the parent.
2803 (num-fmt (format "%%%dd"
2804 (1+ (floor (log (1+ (length children)) 10)))))
2805 fnd)
2806 (when (not (equal numbering ""))
2807 ;; Add separating dot to existing numbering.
2808 (setq numbering (concat numbering ".")))
2809 (dolist (child children fnd)
2810 (setq fnd
2811 (or (rst-toc-insert-stn child buf style depth indent
2812 (concat numbering (format num-fmt count))
2813 keymap tgt-stn) fnd))
2814 (cl-incf count))))
2815
2816;; FIXME refactoring: Use `rst-Stn-buffer' instead of `buf'.
2817(defun rst-toc-insert-stn (stn buf style depth indent numbering keymap tgt-stn)
2818 ;; testcover: ok.
2819 "In the current buffer at point insert STN in BUF into table of contents.
2820See `rst-toc-insert-tree' for STYLE, DEPTH and TGT-STN. INDENT
2821is the indentation depth to use for STN. NUMBERING is the prefix
2822numbering for STN. See `rst-toc-insert-link' for KEYMAP."
2823 (when (or (not depth) (> depth 0))
2824 (cl-destructuring-bind
2825 (pfx add
2826 &aux (fnd (when (and tgt-stn
2827 (equal (rst-Stn-get-title-beginning stn)
2828 (rst-Stn-get-title-beginning tgt-stn)))
2829 (point))))
2830 (cond
2831 ((eq style 'plain)
2832 (list "" rst-toc-indent))
2833 ((eq style 'fixed)
2834 (list (concat numbering rst-toc-insert-number-separator)
2835 rst-toc-indent))
2836 ((eq style 'aligned)
2837 (list (concat numbering rst-toc-insert-number-separator)
2838 (+ (length numbering)
2839 (length rst-toc-insert-number-separator))))
2840 ((eq style 'listed)
2841 (list (format "%c " (car rst-preferred-bullets)) 2)))
2842 ;; Indent using spaces so buffer characteristics like `indent-tabs-mode'
2843 ;; do not matter.
2844 (rst-toc-insert-link (concat (make-string indent ? ) pfx) stn buf keymap)
2845 (or (rst-toc-insert-children (rst-Stn-children stn) buf style
2846 (when depth
2847 (1- depth))
2848 (+ indent add) numbering keymap tgt-stn)
2849 fnd))))
2842 2850
2843(defun rst-toc-update () 2851(defun rst-toc-update ()
2852 ;; testcover: ok.
2844 "Automatically find the contents section of a document and update. 2853 "Automatically find the contents section of a document and update.
2845Updates the inserted TOC if present. You can use this in your 2854Updates the inserted TOC if present. You can use this in your
2846file-write hook to always make it up-to-date automatically." 2855file-write hook to always make it up-to-date automatically."
2847 (interactive) 2856 (interactive)
2848 (save-excursion 2857 (save-match-data
2849 ;; Find and delete an existing comment after the first contents directive. 2858 (save-excursion
2850 ;; Delete that region. 2859 ;; Find and delete an existing comment after the first contents
2851 (goto-char (point-min)) 2860 ;; directive. Delete that region.
2852 ;; We look for the following and the following only (in other words, if your 2861 (goto-char (point-min))
2853 ;; syntax differs, this won't work.). 2862 ;; FIXME: Should accept indentation of the whole block.
2854 ;; 2863 ;; We look for the following and the following only (in other words, if
2855 ;; .. contents:: [...anything here...] 2864 ;; your syntax differs, this won't work.).
2856 ;; [:field: value]... 2865 ;;
2857 ;; .. 2866 ;; .. contents:: [...anything here...]
2858 ;; XXXXXXXX 2867 ;; [:field: value]...
2859 ;; XXXXXXXX 2868 ;; ..
2860 ;; [more lines] 2869 ;; XXXXXXXX
2861 (let ((beg (re-search-forward 2870 ;; XXXXXXXX
2862 (rst-re "^" 'exm-sta "contents" 'dcl-tag ".*\n" 2871 ;; [more lines]
2863 "\\(?:" 'hws-sta 'fld-tag ".*\n\\)*" 'exm-tag) nil t)) 2872 ;; FIXME: Works only for the first of these tocs. There should be a
2864 last-real) 2873 ;; fixed text after the comment such as "RST-MODE ELECTRIC TOC".
2865 (when beg 2874 ;; May be parameters such as `max-level' should be appended.
2866 ;; Look for the first line that starts at the first column. 2875 (let ((beg (re-search-forward
2867 (forward-line 1) 2876 (1value
2868 (while (and 2877 (rst-re "^" 'exm-sta "contents" 'dcl-tag ".*\n"
2869 (< (point) (point-max)) 2878 "\\(?:" 'hws-sta 'fld-tag ".*\n\\)*" 'exm-tag))
2870 (or (if (looking-at 2879 nil t))
2871 (rst-re 'hws-sta "\\S ")) ; indented content. 2880 fnd)
2872 (setq last-real (point))) 2881 (when
2873 (looking-at (rst-re 'lin-end)))) ; empty line. 2882 (and beg
2874 (forward-line 1)) 2883 (rst-forward-line-looking-at
2875 (if last-real 2884 1 'lin-end
2876 (progn 2885 #'(lambda (mtcd)
2877 (goto-char last-real) 2886 (unless mtcd
2878 (end-of-line) 2887 (rst-apply-indented-blocks
2879 (delete-region beg (point))) 2888 (point) (point-max) (current-indentation)
2880 (goto-char beg)) 2889 #'(lambda (count _in-first _in-sub in-super in-empty
2881 (insert "\n ") 2890 _relind)
2882 (rst-toc-insert)))) 2891 (cond
2892 ((or (> count 1) in-super))
2893 ((not in-empty)
2894 (setq fnd (line-end-position))
2895 nil)))))
2896 t)))
2897 (when fnd
2898 (delete-region beg fnd))
2899 (goto-char beg)
2900 (insert "\n ")
2901 ;; FIXME: Ignores an `max-level' given to the original
2902 ;; `rst-toc-insert'. `max-level' could be rendered to the first
2903 ;; line.
2904 (rst-toc-insert)))))
2883 ;; Note: always return nil, because this may be used as a hook. 2905 ;; Note: always return nil, because this may be used as a hook.
2884 nil) 2906 nil)
2885 2907
@@ -2891,58 +2913,26 @@ file-write hook to always make it up-to-date automatically."
2891;; ;; Disable undo for the write file hook. 2913;; ;; Disable undo for the write file hook.
2892;; (let ((buffer-undo-list t)) (rst-toc-update) )) 2914;; (let ((buffer-undo-list t)) (rst-toc-update) ))
2893 2915
2894(defalias 'rst-toc-insert-update 'rst-toc-update) ; backwards compat. 2916;; Maintain an alias for compatibility.
2917(defalias 'rst-toc-insert-update 'rst-toc-update)
2895 2918
2896(defun rst-toc-node (stn buf target) 2919(defconst rst-toc-buffer-name "*Table of Contents*"
2897 "Insert STN in the table-of-contents of buffer BUF.
2898If TARGET is given and this call renders a `rst-Stn' at the same
2899location return position of beginning of line. Otherwise return
2900nil."
2901 (let ((beg (point))
2902 fnd)
2903 (if (or (not stn) (rst-Stn-is-top stn))
2904 (progn
2905 (insert (format "Table of Contents:\n"))
2906 (put-text-property beg (point)
2907 'face (list '(background-color . "gray"))))
2908 (when (and target
2909 (equal (rst-Stn-get-title-beginning stn)
2910 (rst-Stn-get-title-beginning target)))
2911 (setq fnd beg))
2912 (insert (make-string (* rst-toc-indent (rst-Stn-level stn)) ? ))
2913 (insert (rst-Stn-get-text stn))
2914 ;; Highlight lines.
2915 (put-text-property beg (point) 'mouse-face 'highlight)
2916 (insert "\n")
2917 ;; Add link on lines.
2918 (put-text-property
2919 beg (point) 'rst-toc-target
2920 (set-marker (make-marker) (rst-Stn-get-title-beginning stn) buf)))
2921 (when stn
2922 (dolist (child (rst-Stn-children stn))
2923 (setq fnd (or (rst-toc-node child buf target) fnd))))
2924 fnd))
2925
2926(defvar rst-toc-buffer-name "*Table of Contents*"
2927 "Name of the Table of Contents buffer.") 2920 "Name of the Table of Contents buffer.")
2928 2921
2929(defvar rst-toc-return-wincfg nil 2922(defvar-local rst-toc-mode-return-wincfg nil
2930 "Window configuration to which to return when leaving the TOC.") 2923 "Window configuration to which to return when leaving the TOC.")
2931 2924
2932(defun rst-toc () 2925(defun rst-toc ()
2933 "Display a table-of-contents. 2926 ;; testcover: ok.
2934Finds all the section titles and their adornments in the 2927 "Display a table of contents for current buffer.
2935file, and displays a hierarchically-organized list of the 2928Displays all section titles found in the current buffer in a
2936titles, which is essentially a table-of-contents of the 2929hierarchical list. The resulting buffer can be navigated, and
2937document. 2930selecting a section title moves the cursor to that section."
2938
2939The Emacs buffer can be navigated, and selecting a section
2940brings the cursor in that section."
2941 (interactive) 2931 (interactive)
2942 (rst-reset-section-caches) 2932 (rst-reset-section-caches)
2943 (let* ((wincfg (list (current-window-configuration) (point-marker))) 2933 (let* ((wincfg (list (current-window-configuration) (point-marker)))
2944 (sectree (rst-all-stn)) 2934 (sectree (rst-all-stn))
2945 (target-node (rst-stn-containing-point sectree)) 2935 (target-stn (rst-stn-containing-point sectree))
2946 (target-buf (current-buffer)) 2936 (target-buf (current-buffer))
2947 (buf (get-buffer-create rst-toc-buffer-name)) 2937 (buf (get-buffer-create rst-toc-buffer-name))
2948 target-pos) 2938 target-pos)
@@ -2950,134 +2940,174 @@ brings the cursor in that section."
2950 (let ((inhibit-read-only t)) 2940 (let ((inhibit-read-only t))
2951 (rst-toc-mode) 2941 (rst-toc-mode)
2952 (delete-region (point-min) (point-max)) 2942 (delete-region (point-min) (point-max))
2953 (setq target-pos (rst-toc-node sectree target-buf target-node)))) 2943 ;; FIXME: Could use a customizable style.
2944 (setq target-pos (rst-toc-insert-tree
2945 sectree target-buf 'plain nil nil target-stn))))
2954 (display-buffer buf) 2946 (display-buffer buf)
2955 (pop-to-buffer buf) 2947 (pop-to-buffer buf)
2956 (setq-local rst-toc-return-wincfg wincfg) 2948 (setq rst-toc-mode-return-wincfg wincfg)
2957 (goto-char (or target-pos (point-min))))) 2949 (goto-char (or target-pos (point-min)))))
2958 2950
2959(defun rst-toc-mode-find-section () 2951;; Maintain an alias for compatibility.
2960 "Get the section from text property at point." 2952(defalias 'rst-goto-section 'rst-toc-follow-link)
2961 (let ((pos (get-text-property (point) 'rst-toc-target))) 2953
2962 (unless pos 2954(defun rst-toc-follow-link (link-buf link-pnt kill)
2963 (error "No section on this line")) 2955 ;; testcover: ok.
2964 (unless (buffer-live-p (marker-buffer pos)) 2956 "Follow the link to the section at LINK-PNT in LINK-BUF.
2965 (error "Buffer for this section was killed")) 2957LINK-PNT and LINK-BUF default to the point in the current buffer.
2966 pos)) 2958With prefix argument KILL a TOC buffer is destroyed. Throw an
2959error if there is no working link at the given position."
2960 (interactive "i\nd\nP")
2961 (unless link-buf
2962 (setq link-buf (current-buffer)))
2963 ;; Do not catch errors from `rst-toc-get-link' because otherwise the error is
2964 ;; suppressed and invisible in interactve use.
2965 (let ((mrkr (rst-toc-get-link link-buf link-pnt)))
2966 (condition-case nil
2967 (rst-toc-mode-return kill)
2968 ;; Catch errors when not in `toc-mode'.
2969 (error nil))
2970 (pop-to-buffer (marker-buffer mrkr))
2971 (goto-char mrkr)
2972 ;; FIXME: Should be a customizable number of lines from beginning or end of
2973 ;; window just like the argument to `recenter`. It would be ideal if
2974 ;; the adornment is always completely visible.
2975 (recenter 5)))
2976
2977;; Maintain an alias for compatibility.
2978(defalias 'rst-toc-mode-goto-section 'rst-toc-mode-follow-link-kill)
2967 2979
2968;; FIXME: Cursor before or behind the list must be handled properly; before the 2980;; FIXME: Cursor before or behind the list must be handled properly; before the
2969;; list should jump to the top and behind the list to the last normal 2981;; list should jump to the top and behind the list to the last normal
2970;; paragraph. 2982;; paragraph.
2971(defun rst-goto-section (&optional kill) 2983(defun rst-toc-mode-follow-link-kill ()
2972 "Go to the section the current line describes. 2984 ;; testcover: ok.
2973If KILL a TOC buffer is destroyed." 2985 "Follow the link to the section at point and kill the TOC buffer."
2974 (interactive) 2986 (interactive)
2975 (let ((pos (rst-toc-mode-find-section))) 2987 (rst-toc-follow-link (current-buffer) (point) t))
2976 (when kill
2977 ;; FIXME: This should rather go to `rst-toc-mode-goto-section'.
2978 (set-window-configuration (car rst-toc-return-wincfg))
2979 (kill-buffer (get-buffer rst-toc-buffer-name)))
2980 (pop-to-buffer (marker-buffer pos))
2981 (goto-char pos)
2982 ;; FIXME: make the recentering conditional on scroll.
2983 (recenter 5)))
2984 2988
2985(defun rst-toc-mode-goto-section () 2989;; Maintain an alias for compatibility.
2986 "Go to the section the current line describes and kill the TOC buffer." 2990(defalias 'rst-toc-mode-mouse-goto 'rst-toc-mouse-follow-link)
2987 (interactive)
2988 (rst-goto-section t))
2989 2991
2990(defun rst-toc-mode-mouse-goto (event) 2992(defun rst-toc-mouse-follow-link (event kill)
2993 ;; testcover: uncovered.
2991 "In `rst-toc' mode, go to the occurrence whose line you click on. 2994 "In `rst-toc' mode, go to the occurrence whose line you click on.
2992EVENT is the input event." 2995EVENT is the input event. Kill TOC buffer if KILL."
2993 (interactive "e") 2996 (interactive "e\ni")
2994 (let ((pos 2997 (rst-toc-follow-link (window-buffer (posn-window (event-end event)))
2995 (with-current-buffer (window-buffer (posn-window (event-end event))) 2998 (posn-point (event-end event)) kill))
2996 (save-excursion 2999
2997 (goto-char (posn-point (event-end event))) 3000;; Maintain an alias for compatibility.
2998 (rst-toc-mode-find-section))))) 3001(defalias 'rst-toc-mode-mouse-goto-kill 'rst-toc-mode-mouse-follow-link-kill)
2999 (pop-to-buffer (marker-buffer pos))
3000 (goto-char pos)
3001 (recenter 5)))
3002 3002
3003(defun rst-toc-mode-mouse-goto-kill (event) 3003(defun rst-toc-mode-mouse-follow-link-kill (event)
3004 "Same as `rst-toc-mode-mouse-goto', but kill TOC buffer as well. 3004 ;; testcover: uncovered.
3005 "Same as `rst-toc-mouse-follow-link', but kill TOC buffer as well.
3005EVENT is the input event." 3006EVENT is the input event."
3006 (interactive "e") 3007 (interactive "e")
3007 (call-interactively 'rst-toc-mode-mouse-goto event) 3008 (rst-toc-mouse-follow-link event t))
3008 (kill-buffer (get-buffer rst-toc-buffer-name))) 3009
3010;; Maintain an alias for compatibility.
3011(defalias 'rst-toc-quit-window 'rst-toc-mode-return)
3012
3013(defun rst-toc-mode-return (kill)
3014 ;; testcover: ok.
3015 "Leave the current TOC buffer and return to the previous environment.
3016With prefix argument KILL non-nil, kill the buffer instead of
3017burying it."
3018 (interactive "P")
3019 (unless rst-toc-mode-return-wincfg
3020 (error "Not in a `toc-mode' buffer"))
3021 (cl-destructuring-bind
3022 (wincfg pos
3023 &aux (toc-buf (current-buffer)))
3024 rst-toc-mode-return-wincfg
3025 (set-window-configuration wincfg)
3026 (goto-char pos)
3027 (if kill
3028 (kill-buffer toc-buf)
3029 (bury-buffer toc-buf))))
3009 3030
3010(defun rst-toc-quit-window () 3031(defun rst-toc-mode-return-kill ()
3011 "Leave the current TOC buffer." 3032 ;; testcover: uncovered.
3033 "Like `rst-toc-mode-return' but kill TOC buffer."
3012 (interactive) 3034 (interactive)
3013 (let ((retbuf rst-toc-return-wincfg)) 3035 (rst-toc-mode-return t))
3014 (set-window-configuration (car retbuf))
3015 (goto-char (cadr retbuf))))
3016 3036
3017(defvar rst-toc-mode-map 3037(defvar rst-toc-mode-map
3018 (let ((map (make-sparse-keymap))) 3038 (let ((map (make-sparse-keymap)))
3019 (define-key map [mouse-1] 'rst-toc-mode-mouse-goto-kill) 3039 (define-key map [mouse-1] #'rst-toc-mode-mouse-follow-link-kill)
3020 ;; FIXME: This very useful function must be on some key. 3040 (define-key map [mouse-2] #'rst-toc-mouse-follow-link)
3021 (define-key map [mouse-2] 'rst-toc-mode-mouse-goto) 3041 (define-key map "\C-m" #'rst-toc-mode-follow-link-kill)
3022 (define-key map "\C-m" 'rst-toc-mode-goto-section) 3042 (define-key map "f" #'rst-toc-mode-follow-link-kill)
3023 (define-key map "f" 'rst-toc-mode-goto-section) 3043 (define-key map "n" #'next-line)
3024 (define-key map "q" 'rst-toc-quit-window) 3044 (define-key map "p" #'previous-line)
3025 ;; FIXME: Killing should clean up like `rst-toc-quit-window' does. 3045 (define-key map "q" #'rst-toc-mode-return)
3026 (define-key map "z" 'kill-this-buffer) 3046 (define-key map "z" #'rst-toc-mode-return-kill)
3027 map) 3047 map)
3028 "Keymap for `rst-toc-mode'.") 3048 "Keymap for `rst-toc-mode'.")
3029 3049
3030(put 'rst-toc-mode 'mode-class 'special) 3050(define-derived-mode rst-toc-mode special-mode "ReST-TOC"
3031
3032;; Could inherit from the new `special-mode'.
3033(define-derived-mode rst-toc-mode nil "ReST-TOC"
3034 "Major mode for output from \\[rst-toc], the table-of-contents for the document. 3051 "Major mode for output from \\[rst-toc], the table-of-contents for the document.
3035
3036\\{rst-toc-mode-map}" 3052\\{rst-toc-mode-map}"
3037 (setq buffer-read-only t)) 3053 ;; FIXME: `revert-buffer-function` must be defined so `revert-buffer` works
3054 ;; as expected for a special mode. In particular the referred buffer
3055 ;; needs to be rescanned and the TOC must be updated accordingly.
3056 ;; FIXME: Should contain the name of the buffer this is the toc of.
3057 (setq header-line-format "Table of Contents"))
3038 3058
3039;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3059;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3040;; Section movement 3060;; Section movement
3041 3061
3042(defun rst-forward-section (&optional offset) 3062;; FIXME testcover: Use `testcover'. Mark up a function with sufficient test
3043 "Skip to the next reStructuredText section title. 3063;; coverage by a comment tagged with `testcover' after the
3044OFFSET specifies how many titles to skip. Use a negative OFFSET 3064;; `defun'. Then move this comment.
3045to move backwards in the file (default is to use 1)." 3065
3046 (interactive) 3066(defun rst-forward-section (offset)
3067 "Jump forward OFFSET section titles ending up at the start of the title line.
3068OFFSET defaults to 1 and may be negative to move backward. An
3069OFFSET of 0 does not move unless point is inside a title. Go to
3070end or beginning of buffer if no more section titles in the desired
3071direction."
3072 (interactive "p")
3047 (rst-reset-section-caches) 3073 (rst-reset-section-caches)
3048 (let* ((offset (or offset 1)) 3074 (let* ((ttls (rst-all-ttls))
3049 (ttls (rst-all-ttls)) 3075 (count (length ttls))
3050 (curpos (line-beginning-position)) 3076 (pnt (point))
3051 (cur ttls) 3077 (contained nil) ; Title contains point (or is after point otherwise).
3052 (idx 0) 3078 (found (or (cl-position-if
3053 ttl) 3079 ;; Find a title containing or after point.
3054 3080 #'(lambda (ttl)
3055 ;; Find the index of the "next" adornment with respect to the current line. 3081 (let ((cmp (rst-Ttl-contains ttl pnt)))
3056 (while (and cur (< (rst-Ttl-get-title-beginning (car cur)) curpos)) 3082 (cond
3057 (setq cur (cdr cur)) 3083 ((= cmp 0) ; Title contains point.
3058 (incf idx)) 3084 (setq contained t)
3059 ;; `cur' is the `rst-Ttl' on or following the current line. 3085 t)
3060 3086 ((> cmp 0) ; Title after point.
3061 (if (and (> offset 0) cur 3087 t))))
3062 (equal (rst-Ttl-get-title-beginning (car cur)) curpos)) 3088 ttls)
3063 (incf idx)) 3089 ;; Point after all titles.
3064 3090 count))
3065 ;; Find the final index. 3091 (target (+ found offset
3066 (setq idx (+ idx (if (> offset 0) (- offset 1) offset))) 3092 ;; If point is in plain text found title is already one
3067 (setq ttl (nth idx ttls)) 3093 ;; step forward.
3094 (if (and (not contained) (>= offset 0)) -1 0))))
3068 (goto-char (cond 3095 (goto-char (cond
3069 ((and ttl (>= idx 0)) 3096 ((< target 0)
3070 (rst-Ttl-get-title-beginning ttl)) 3097 (point-min))
3071 ((> offset 0) 3098 ((>= target count)
3072 (point-max)) 3099 (point-max))
3073 ((point-min)))))) 3100 ((and (not contained) (= offset 0))
3101 ;; Point not in title and should not move - do not move.
3102 pnt)
3103 ((rst-Ttl-get-title-beginning (nth target ttls)))))))
3074 3104
3075(defun rst-backward-section () 3105(defun rst-backward-section (offset)
3076 "Like `rst-forward-section', except move back one title." 3106 "Like `rst-forward-section', except move backward by OFFSET."
3077 (interactive) 3107 (interactive "p")
3078 (rst-forward-section -1)) 3108 (rst-forward-section (- offset)))
3079 3109
3080;; FIXME: What is `allow-extend' for? 3110;; FIXME: What is `allow-extend' for? See `mark-paragraph' for an explanation.
3081(defun rst-mark-section (&optional count allow-extend) 3111(defun rst-mark-section (&optional count allow-extend)
3082 "Select COUNT sections around point. 3112 "Select COUNT sections around point.
3083Mark following sections for positive COUNT or preceding sections 3113Mark following sections for positive COUNT or preceding sections
@@ -3110,16 +3140,18 @@ The line containing the start of the region is always considered
3110spanned. If the region ends at the beginning of a line this line 3140spanned. If the region ends at the beginning of a line this line
3111is not considered spanned, otherwise it is spanned." 3141is not considered spanned, otherwise it is spanned."
3112 (let (mincol) 3142 (let (mincol)
3113 (save-excursion 3143 (save-match-data
3114 (goto-char beg) 3144 (save-excursion
3115 (while (< (point) end) 3145 (goto-char beg)
3116 (back-to-indentation) 3146 (1value
3117 (unless (looking-at (rst-re 'lin-end)) 3147 (rst-forward-line-strict 0))
3118 (setq mincol (if mincol 3148 (while (< (point) end)
3119 (min mincol (current-column)) 3149 (unless (looking-at (rst-re 'lin-end))
3120 (current-column)))) 3150 (setq mincol (if mincol
3121 (forward-line 1))) 3151 (min mincol (current-indentation))
3122 mincol)) 3152 (current-indentation))))
3153 (rst-forward-line-strict 1 end)))
3154 mincol)))
3123 3155
3124;; FIXME: At the moment only block comments with leading empty comment line are 3156;; FIXME: At the moment only block comments with leading empty comment line are
3125;; supported. Comment lines with leading comment markup should be also 3157;; supported. Comment lines with leading comment markup should be also
@@ -3183,7 +3215,7 @@ COLUMN is the column of the tab. INNER is non-nil if this is an
3183inner tab. I.e. a tab which does come from the basic indentation 3215inner tab. I.e. a tab which does come from the basic indentation
3184and not from inner alignment points." 3216and not from inner alignment points."
3185 (save-excursion 3217 (save-excursion
3186 (forward-line 0) 3218 (rst-forward-line-strict 0)
3187 (save-match-data 3219 (save-match-data
3188 (unless (looking-at (rst-re 'lin-end)) 3220 (unless (looking-at (rst-re 'lin-end))
3189 (back-to-indentation) 3221 (back-to-indentation)
@@ -3205,7 +3237,8 @@ and not from inner alignment points."
3205 (if (zerop rst-indent-field) 3237 (if (zerop rst-indent-field)
3206 (push (list (match-end 2) 3238 (push (list (match-end 2)
3207 (if (string= (match-string 2) "") 1 0) 3239 (if (string= (match-string 2) "") 1 0)
3208 t) tabs)))) 3240 t)
3241 tabs))))
3209 ;; Directive. 3242 ;; Directive.
3210 ((looking-at (rst-re 'dir-sta-3 '(:grp "\\S ") "?")) 3243 ((looking-at (rst-re 'dir-sta-3 '(:grp "\\S ") "?"))
3211 (push (list (match-end 1) 0 t) tabs) 3244 (push (list (match-end 1) 0 t) tabs)
@@ -3223,16 +3256,18 @@ and not from inner alignment points."
3223 (push (list (point) rst-indent-comment t) tabs))) 3256 (push (list (point) rst-indent-comment t) tabs)))
3224 ;; Start of literal block. 3257 ;; Start of literal block.
3225 (when (looking-at (rst-re 'lit-sta-2)) 3258 (when (looking-at (rst-re 'lit-sta-2))
3226 (let ((tab0 (first tabs))) 3259 (cl-destructuring-bind (point offset _inner) (car tabs)
3227 (push (list (first tab0) 3260 (push (list point
3228 (+ (second tab0) 3261 (+ offset
3229 (if (match-string 1) 3262 (if (match-string 1)
3230 rst-indent-literal-minimized 3263 rst-indent-literal-minimized
3231 rst-indent-literal-normal)) 3264 rst-indent-literal-normal))
3232 t) tabs))) 3265 t)
3233 (mapcar (lambda (tab) 3266 tabs)))
3234 (goto-char (first tab)) 3267 (mapcar (cl-function
3235 (cons (+ (current-column) (second tab)) (third tab))) 3268 (lambda ((point offset inner))
3269 (goto-char point)
3270 (cons (+ (current-column) offset) inner)))
3236 tabs)))))) 3271 tabs))))))
3237 3272
3238(defun rst-compute-tabs (pt) 3273(defun rst-compute-tabs (pt)
@@ -3242,38 +3277,35 @@ Return a list of tabs sorted by likeliness to continue writing
3242like `rst-line-tabs'. Nearer lines have generally a higher 3277like `rst-line-tabs'. Nearer lines have generally a higher
3243likeliness than farther lines. Return nil if no tab is found in 3278likeliness than farther lines. Return nil if no tab is found in
3244the text above." 3279the text above."
3280 ;; FIXME: See test `indent-for-tab-command-BUGS`.
3245 (save-excursion 3281 (save-excursion
3246 (goto-char pt) 3282 (goto-char pt)
3247 (let (leftmost ; Leftmost column found so far. 3283 (let (leftmost ; Leftmost column found so far.
3248 innermost ; Leftmost column for inner tab. 3284 innermost ; Leftmost column for inner tab.
3249 tablist) 3285 tablist)
3250 (while (and (zerop (forward-line -1)) 3286 (while (and (rst-forward-line-strict -1)
3251 (or (not leftmost) 3287 (or (not leftmost)
3252 (> leftmost 0))) 3288 (> leftmost 0)))
3253 (let* ((tabs (rst-line-tabs)) 3289 (let ((tabs (rst-line-tabs)))
3254 (leftcol (if tabs (apply 'min (mapcar 'car tabs)))))
3255 (when tabs 3290 (when tabs
3256 ;; Consider only lines indented less or same if not INNERMOST. 3291 (let ((leftcol (apply #'min (mapcar #'car tabs))))
3257 (when (or (not leftmost) 3292 ;; Consider only lines indented less or same if not INNERMOST.
3258 (< leftcol leftmost) 3293 (when (or (not leftmost)
3259 (and (not innermost) (= leftcol leftmost))) 3294 (< leftcol leftmost)
3260 (dolist (tab tabs) 3295 (and (not innermost) (= leftcol leftmost)))
3261 (let ((inner (cdr tab)) 3296 (rst-destructuring-dolist ((column &rest inner) tabs)
3262 (newcol (car tab))) 3297 (when (or
3263 (when (and 3298 (and (not inner)
3264 (or 3299 (or (not leftmost)
3265 (and (not inner) 3300 (< column leftmost)))
3266 (or (not leftmost) 3301 (and inner
3267 (< newcol leftmost))) 3302 (or (not innermost)
3268 (and inner 3303 (< column innermost))))
3269 (or (not innermost) 3304 (setq tablist (cl-adjoin column tablist))))
3270 (< newcol innermost)))) 3305 (setq innermost (if (cl-some #'cdr tabs) ; Has inner.
3271 (not (memq newcol tablist))) 3306 leftcol
3272 (push newcol tablist)))) 3307 innermost))
3273 (setq innermost (if (rst-some (mapcar 'cdr tabs)) ; Has inner. 3308 (setq leftmost leftcol))))))
3274 leftcol
3275 innermost))
3276 (setq leftmost leftcol)))))
3277 (nreverse tablist)))) 3309 (nreverse tablist))))
3278 3310
3279(defun rst-indent-line (&optional dflt) 3311(defun rst-indent-line (&optional dflt)
@@ -3291,7 +3323,7 @@ relative to the content."
3291 (cur (current-indentation)) 3323 (cur (current-indentation))
3292 (clm (current-column)) 3324 (clm (current-column))
3293 (tabs (rst-compute-tabs (point))) 3325 (tabs (rst-compute-tabs (point)))
3294 (fnd (rst-position cur tabs)) 3326 (fnd (cl-position cur tabs :test #'equal))
3295 ind) 3327 ind)
3296 (if (and (not tabs) (not dflt)) 3328 (if (and (not tabs) (not dflt))
3297 'noindent 3329 'noindent
@@ -3315,7 +3347,9 @@ Shift by one tab to the right (CNT > 0) or left (CNT < 0) or
3315remove all indentation (CNT = 0). A tab is taken from the text 3347remove all indentation (CNT = 0). A tab is taken from the text
3316above. If no suitable tab is found `rst-indent-width' is used." 3348above. If no suitable tab is found `rst-indent-width' is used."
3317 (interactive "r\np") 3349 (interactive "r\np")
3318 (let ((tabs (sort (rst-compute-tabs beg) (lambda (x y) (<= x y)))) 3350 (let ((tabs (sort (rst-compute-tabs beg)
3351 #'(lambda (x y)
3352 (<= x y))))
3319 (leftmostcol (rst-find-leftmost-column beg end))) 3353 (leftmostcol (rst-find-leftmost-column beg end)))
3320 (when (or (> leftmostcol 0) (> cnt 0)) 3354 (when (or (> leftmostcol 0) (> cnt 0))
3321 ;; Apply the indent. 3355 ;; Apply the indent.
@@ -3324,17 +3358,15 @@ above. If no suitable tab is found `rst-indent-width' is used."
3324 (if (zerop cnt) 3358 (if (zerop cnt)
3325 (- leftmostcol) 3359 (- leftmostcol)
3326 ;; Find the next tab after the leftmost column. 3360 ;; Find the next tab after the leftmost column.
3327 (let* ((cmp (if (> cnt 0) '> '<)) 3361 (let* ((cmp (if (> cnt 0) #'> #'<))
3328 (tabs (if (> cnt 0) tabs (reverse tabs))) 3362 (tabs (if (> cnt 0) tabs (reverse tabs)))
3329 (len (length tabs)) 3363 (len (length tabs))
3330 (dir (rst-signum cnt)) ; Direction to take. 3364 (dir (cl-signum cnt)) ; Direction to take.
3331 (abs (abs cnt)) ; Absolute number of steps to take. 3365 (abs (abs cnt)) ; Absolute number of steps to take.
3332 ;; Get the position of the first tab beyond leftmostcol. 3366 ;; Get the position of the first tab beyond leftmostcol.
3333 (fnd (lexical-let ((cmp cmp) 3367 (fnd (cl-position-if #'(lambda (elt)
3334 (leftmostcol leftmostcol)) ;; Create closure. 3368 (funcall cmp elt leftmostcol))
3335 (rst-position-if (lambda (elt) 3369 tabs))
3336 (funcall cmp elt leftmostcol))
3337 tabs)))
3338 ;; Virtual position of tab. 3370 ;; Virtual position of tab.
3339 (pos (+ (or fnd len) (1- abs))) 3371 (pos (+ (or fnd len) (1- abs)))
3340 (tab (if (< pos len) 3372 (tab (if (< pos len)
@@ -3357,20 +3389,21 @@ above. If no suitable tab is found `rst-indent-width' is used."
3357(defun rst-adaptive-fill () 3389(defun rst-adaptive-fill ()
3358 "Return fill prefix found at point. 3390 "Return fill prefix found at point.
3359Value for `adaptive-fill-function'." 3391Value for `adaptive-fill-function'."
3360 (let ((fnd (if (looking-at adaptive-fill-regexp) 3392 (save-match-data
3361 (match-string-no-properties 0)))) 3393 (let ((fnd (if (looking-at adaptive-fill-regexp)
3362 (if (save-match-data 3394 (match-string-no-properties 0))))
3363 (not (string-match comment-start-skip fnd))) 3395 (if (save-match-data
3364 ;; An non-comment prefix is fine. 3396 (not (string-match comment-start-skip fnd)))
3365 fnd 3397 ;; An non-comment prefix is fine.
3366 ;; Matches a comment - return whitespace instead. 3398 fnd
3367 (make-string (- 3399 ;; Matches a comment - return whitespace instead.
3368 (save-excursion 3400 (make-string (-
3369 (goto-char (match-end 0)) 3401 (save-excursion
3370 (current-column)) 3402 (goto-char (match-end 0))
3371 (save-excursion 3403 (current-column))
3372 (goto-char (match-beginning 0)) 3404 (save-excursion
3373 (current-column))) ? )))) 3405 (goto-char (match-beginning 0))
3406 (current-column))) ? )))))
3374 3407
3375;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3408;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3376;; Comments 3409;; Comments
@@ -3406,10 +3439,9 @@ Region is from BEG to END. Uncomment if ARG."
3406 (if (consp arg) 3439 (if (consp arg)
3407 (rst-uncomment-region beg end arg) 3440 (rst-uncomment-region beg end arg)
3408 (goto-char beg) 3441 (goto-char beg)
3442 (rst-forward-line-strict 0)
3409 (let ((ind (current-indentation)) 3443 (let ((ind (current-indentation))
3410 bol) 3444 (bol (point)))
3411 (forward-line 0)
3412 (setq bol (point))
3413 (indent-rigidly bol end rst-indent-comment) 3445 (indent-rigidly bol end rst-indent-comment)
3414 (goto-char bol) 3446 (goto-char bol)
3415 (open-line 1) 3447 (open-line 1)
@@ -3420,14 +3452,13 @@ Region is from BEG to END. Uncomment if ARG."
3420 "Uncomment the current region. 3452 "Uncomment the current region.
3421Region is from BEG to END. _ARG is ignored" 3453Region is from BEG to END. _ARG is ignored"
3422 (save-excursion 3454 (save-excursion
3423 (let (bol eol) 3455 (goto-char beg)
3424 (goto-char beg) 3456 (rst-forward-line-strict 0)
3425 (forward-line 0) 3457 (let ((bol (point)))
3426 (setq bol (point)) 3458 (rst-forward-line-strict 1 end)
3427 (forward-line 1) 3459 (indent-rigidly (point) end (- rst-indent-comment))
3428 (setq eol (point)) 3460 (goto-char bol)
3429 (indent-rigidly eol end (- rst-indent-comment)) 3461 (rst-delete-entire-line 0))))
3430 (delete-region bol eol))))
3431 3462
3432;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3463;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3433;; Apply to indented block 3464;; Apply to indented block
@@ -3445,95 +3476,94 @@ containing or after BEG and indented to IND. After the first
3445line the indented block may contain more lines with same 3476line the indented block may contain more lines with same
3446indentation (the paragraph) followed by empty lines and lines 3477indentation (the paragraph) followed by empty lines and lines
3447more indented (the sub-blocks). A following line indented to IND 3478more indented (the sub-blocks). A following line indented to IND
3448starts the next indented block. A line with less indentation 3479starts the next paragraph. A non-empty line with less
3449than IND terminates the current indented block. Such lines and 3480indentation than IND terminates the current paragraph. FUN is
3450all following lines not indented to IND are skipped. FUN is 3481applied to each line like this
3451applied to unskipped lines like this 3482
3452 3483 (FUN COUNT IN-FIRST IN-SUB IN-SUPER IN-EMPTY RELIND)
3453 (FUN COUNT FIRSTP SUBP EMPTYP RELIND LASTRET) 3484
3454 3485COUNT is 0 before the first paragraph and increments for every
3455COUNT is 0 before the first indented block and increments for 3486paragraph found on level IND. IN-FIRST is non-nil if this is the
3456every indented block found. 3487first line of such a paragraph. IN-SUB is non-nil if this line
3457 3488is part of a sub-block while IN-SUPER is non-nil of this line is
3458FIRSTP is t when this is the first line of the paragraph. 3489part of a less indented block (super-block). IN-EMPTY is non-nil
3459 3490if this line is empty where an empty line is considered being
3460SUBP is t when this line is part of a sub-block. 3491part of the previous block. RELIND is nil for an empty line, 0
3461 3492for a line indented to IND, and the positive or negative number
3462EMPTYP is t when this line is empty. 3493of columns more or less indented otherwise. When FUN is called
3463 3494point is immediately behind indentation of that line. FUN may
3464RELIND is nil for an empty line, 0 for a line indented to IND, 3495change everything as long as a marker at END and at the beginning
3465and the number of columns more indented otherwise. 3496of the following line is handled correctly by the change. A
3466 3497non-nil return value from FUN breaks the loop and is returned.
3467LASTRET is the return value of FUN returned by the last 3498Otherwise return nil."
3468invocation for the same indented block or nil for the first 3499 (let ((endm (copy-marker end t))
3469invocation. 3500 (count 0) ; Before first indented block.
3470 3501 (nxt (when (< beg end)
3471When FUN is called point is immediately behind indentation of 3502 (copy-marker beg t)))
3472that line. FUN may change everything as long as a marker at END 3503 (broken t)
3473is handled correctly by the change. 3504 in-sub in-super stop)
3474 3505 (save-match-data
3475Return the return value of the last invocation of FUN or nil if 3506 (save-excursion
3476FUN was never called." 3507 (while (and (not stop) nxt)
3477 (let (lastret 3508 (set-marker
3478 subp 3509 (goto-char nxt) nil)
3479 skipping 3510 (setq nxt (save-excursion
3480 nextm 3511 ;; FIXME refactoring: Replace `(forward-line)
3481 (count 0) ; Before first indented block 3512 ;; (back-to-indentation)` by
3482 (endm (copy-marker end t))) 3513 ;; `(forward-to-indentation)`
3483 (save-excursion 3514 (when (and (rst-forward-line-strict 1 endm)
3484 (goto-char beg) 3515 (< (point) endm))
3485 (while (< (point) endm) 3516 (copy-marker (point) t))))
3486 (save-excursion
3487 (setq nextm (save-excursion
3488 (forward-line 1)
3489 (copy-marker (point) t)))
3490 (back-to-indentation) 3517 (back-to-indentation)
3491 (let (firstp 3518 (let ((relind (- (current-indentation) ind))
3492 emptyp 3519 (in-empty (looking-at (rst-re 'lin-end)))
3493 (relind (- (current-column) ind))) 3520 in-first)
3494 (cond 3521 (cond
3495 ((looking-at (rst-re 'lin-end)) 3522 (in-empty
3496 (setq emptyp t) 3523 (setq relind nil))
3497 (setq relind nil) 3524 ((< relind 0)
3498 ;; Breaks indented block if one is started 3525 (setq in-sub nil)
3499 (setq subp (not (zerop count)))) 3526 (setq in-super t))
3500 ((< relind 0) ; Less indented 3527 ((> relind 0)
3501 (setq skipping t)) 3528 (setq in-sub t)
3502 ((zerop relind) ; In indented block 3529 (setq in-super nil))
3503 (when (or subp skipping (zerop count)) 3530 (t ; Non-empty line in indented block.
3504 (setq firstp t) 3531 (when (or broken in-sub in-super)
3505 (incf count)) 3532 (setq in-first t)
3506 (setq subp nil) 3533 (cl-incf count))
3507 (setq skipping nil)) 3534 (setq in-sub nil)
3508 (t ; More indented 3535 (setq in-super nil)))
3509 (setq subp t))) 3536 (save-excursion
3510 (unless skipping 3537 (setq
3511 (setq lastret 3538 stop
3512 (funcall fun count firstp subp emptyp relind lastret))))) 3539 (funcall fun count in-first in-sub in-super in-empty relind)))
3513 (goto-char nextm)) 3540 (setq broken in-empty)))
3514 lastret))) 3541 (set-marker endm nil)
3542 stop))))
3515 3543
3516(defun rst-enumerate-region (beg end all) 3544(defun rst-enumerate-region (beg end all)
3517 "Add enumeration to all the leftmost paragraphs in the given region. 3545 "Add enumeration to all the leftmost paragraphs in the given region.
3518The region is specified between BEG and END. With ALL, 3546The region is specified between BEG and END. With ALL,
3519do all lines instead of just paragraphs." 3547do all lines instead of just paragraphs."
3520 (interactive "r\nP") 3548 (interactive "r\nP")
3521 (let ((enum 0)) 3549 (let ((enum 0)
3550 (indent ""))
3522 (rst-apply-indented-blocks 3551 (rst-apply-indented-blocks
3523 beg end (rst-find-leftmost-column beg end) 3552 beg end (rst-find-leftmost-column beg end)
3524 (lambda (count firstp subp emptyp relind lastret) 3553 #'(lambda (count in-first in-sub in-super in-empty _relind)
3525 (cond 3554 (cond
3526 (emptyp) 3555 (in-empty)
3527 ((zerop count)) 3556 (in-super)
3528 (subp 3557 ((zerop count))
3529 (insert lastret)) 3558 (in-sub
3530 ((or firstp all) 3559 (insert indent))
3531 (let ((ins (format "%d. " (incf enum)))) 3560 ((or in-first all)
3532 (setq lastret (make-string (length ins) ?\ )) 3561 (let ((tag (format "%d. " (cl-incf enum))))
3533 (insert ins))) 3562 (setq indent (make-string (length tag) ? ))
3534 (t 3563 (insert tag)))
3535 (insert lastret))) 3564 (t
3536 lastret)))) 3565 (insert indent)))
3566 nil))))
3537 3567
3538;; FIXME: Does not deal with deeper indentation - although 3568;; FIXME: Does not deal with deeper indentation - although
3539;; `rst-apply-indented-blocks' could. 3569;; `rst-apply-indented-blocks' could.
@@ -3544,21 +3574,22 @@ do all lines instead of just paragraphs."
3544 (interactive "r\nP") 3574 (interactive "r\nP")
3545 (unless rst-preferred-bullets 3575 (unless rst-preferred-bullets
3546 (error "No preferred bullets defined")) 3576 (error "No preferred bullets defined"))
3547 (let ((bul (format "%c " (car rst-preferred-bullets))) 3577 (let* ((bul (format "%c " (car rst-preferred-bullets)))
3548 (cont " ")) 3578 (indent (make-string (length bul) ? )))
3549 (rst-apply-indented-blocks 3579 (rst-apply-indented-blocks
3550 beg end (rst-find-leftmost-column beg end) 3580 beg end (rst-find-leftmost-column beg end)
3551 (lambda (count firstp subp emptyp relind lastret) 3581 #'(lambda (count in-first in-sub in-super in-empty _relind)
3552 (cond 3582 (cond
3553 (emptyp) 3583 (in-empty)
3554 ((zerop count)) 3584 (in-super)
3555 (subp 3585 ((zerop count))
3556 (insert cont)) 3586 (in-sub
3557 ((or firstp all) 3587 (insert indent))
3558 (insert bul)) 3588 ((or in-first all)
3559 (t 3589 (insert bul))
3560 (insert cont))) 3590 (t
3561 nil)))) 3591 (insert indent)))
3592 nil))))
3562 3593
3563;; FIXME: Does not deal with a varying number of digits appropriately. 3594;; FIXME: Does not deal with a varying number of digits appropriately.
3564;; FIXME: Does not deal with multiple levels independently. 3595;; FIXME: Does not deal with multiple levels independently.
@@ -3567,19 +3598,19 @@ do all lines instead of just paragraphs."
3567 "Convert the bulleted and enumerated items in the region to enumerated lists. 3598 "Convert the bulleted and enumerated items in the region to enumerated lists.
3568Renumber as necessary. Region is from BEG to END." 3599Renumber as necessary. Region is from BEG to END."
3569 (interactive "r") 3600 (interactive "r")
3570 (let* (;; Find items and convert the positions to markers. 3601 (let ((count 1))
3571 (items (mapcar 3602 (save-match-data
3572 (lambda (x) 3603 (save-excursion
3573 (cons (copy-marker (car x)) 3604 (dolist (marker (mapcar
3574 (cdr x))) 3605 (cl-function
3575 (rst-find-pfx-in-region beg end (rst-re 'itmany-sta-1)))) 3606 (lambda ((pnt &rest clm))
3576 (count 1)) 3607 (copy-marker pnt)))
3577 (save-excursion 3608 (rst-find-begs beg end 'itmany-beg-1)))
3578 (dolist (x items) 3609 (set-marker
3579 (goto-char (car x)) 3610 (goto-char marker) nil)
3580 (looking-at (rst-re 'itmany-beg-1)) 3611 (looking-at (rst-re 'itmany-beg-1))
3581 (replace-match (format "%d." count) nil nil nil 1) 3612 (replace-match (format "%d." count) nil nil nil 1)
3582 (incf count))))) 3613 (cl-incf count))))))
3583 3614
3584(defun rst-line-block-region (beg end &optional with-empty) 3615(defun rst-line-block-region (beg end &optional with-empty)
3585 "Add line block prefixes for a region. 3616 "Add line block prefixes for a region.
@@ -3588,10 +3619,11 @@ Region is from BEG to END. With WITH-EMPTY prefix empty lines too."
3588 (let ((ind (rst-find-leftmost-column beg end))) 3619 (let ((ind (rst-find-leftmost-column beg end)))
3589 (rst-apply-indented-blocks 3620 (rst-apply-indented-blocks
3590 beg end ind 3621 beg end ind
3591 (lambda (count firstp subp emptyp relind lastret) 3622 #'(lambda (_count _in-first _in-sub in-super in-empty _relind)
3592 (when (or with-empty (not emptyp)) 3623 (when (and (not in-super) (or with-empty (not in-empty)))
3593 (move-to-column ind t) 3624 (move-to-column ind t)
3594 (insert "| ")))))) 3625 (insert "| "))
3626 nil))))
3595 3627
3596 3628
3597;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3629;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -4040,14 +4072,16 @@ Return nil if not or a cons with new values for BEG / END"
4040 (if (or nbeg nend) 4072 (if (or nbeg nend)
4041 (cons (or nbeg beg) (or nend end))))) 4073 (cons (or nbeg beg) (or nend end)))))
4042 4074
4075;; FIXME refactoring: Use `rst-forward-line-strict' instead.
4043(defun rst-forward-line (&optional n) 4076(defun rst-forward-line (&optional n)
4044 "Like `forward-line' but always end up in column 0 and return accordingly. 4077 "Like `forward-line' but always end up in column 0 and return accordingly.
4045Move N lines forward just as `forward-line'." 4078Move N lines forward just as `forward-line'."
4046 (let ((moved (forward-line n))) 4079 (let ((left (forward-line n)))
4047 (if (bolp) 4080 (if (bolp)
4048 moved 4081 left
4082 ;; FIXME: This may move back for positive n - is this desired?
4049 (forward-line 0) 4083 (forward-line 0)
4050 (- moved (rst-signum n))))) 4084 (- left (cl-signum n)))))
4051 4085
4052;; FIXME: If a single line is made a section header by `rst-adjust' the header 4086;; FIXME: If a single line is made a section header by `rst-adjust' the header
4053;; is not always fontified immediately. 4087;; is not always fontified immediately.
@@ -4068,77 +4102,73 @@ Return extended point or nil if not moved."
4068 ;; The second group consists of the adornment cases. 4102 ;; The second group consists of the adornment cases.
4069 (if (not (get-text-property pt 'font-lock-multiline)) 4103 (if (not (get-text-property pt 'font-lock-multiline))
4070 ;; Move only if we don't start inside a multiline construct already. 4104 ;; Move only if we don't start inside a multiline construct already.
4071 (save-excursion 4105 (save-match-data
4072 (let (;; Non-empty non-indented line, explicit markup tag or literal 4106 (save-excursion
4073 ;; block tag. 4107 (let ( ; Non-empty non-indented line, explicit markup tag or literal
4074 (stop-re (rst-re '(:alt "[^ \t\n]" 4108 ; block tag.
4075 (:seq hws-tag exm-tag) 4109 (stop-re (rst-re '(:alt "[^ \t\n]"
4076 (:seq ".*" dcl-tag lin-end))))) 4110 (:seq hws-tag exm-tag)
4077 ;; The comments below are for dir == -1 / dir == 1. 4111 (:seq ".*" dcl-tag lin-end)))))
4078 (goto-char pt) 4112 ;; The comments below are for dir == -1 / dir == 1.
4079 (forward-line 0) 4113 (goto-char pt)
4080 (setq pt (point)) 4114 (rst-forward-line-strict 0)
4081 (while (and (not (looking-at stop-re)) 4115 (setq pt (point))
4082 (zerop (rst-forward-line dir)))) ; try previous / next 4116 (while (and (not (looking-at stop-re))
4083 ; line if it exists. 4117 (zerop (rst-forward-line dir)))) ; try previous / next
4084 (if (looking-at (rst-re 'ado-beg-2-1)) ; may be an underline / 4118 ; line if it exists.
4085 ; overline. 4119 (if (looking-at (rst-re 'ado-beg-2-1)) ; may be an underline /
4086 (if (zerop (rst-forward-line dir)) 4120 ; overline.
4087 (if (looking-at (rst-re 'ttl-beg-1)) ; title found, i.e.
4088 ; underline / overline
4089 ; found.
4090 (if (zerop (rst-forward-line dir))
4091 (if (not
4092 (looking-at (rst-re 'ado-beg-2-1))) ; no
4093 ; overline /
4094 ; underline.
4095 (rst-forward-line (- dir)))) ; step back to title
4096 ; / adornment.
4097 (if (< dir 0) ; keep downward adornment.
4098 (rst-forward-line (- dir))))) ; step back to adornment.
4099 (if (looking-at (rst-re 'ttl-beg-1)) ; may be a title.
4100 (if (zerop (rst-forward-line dir)) 4121 (if (zerop (rst-forward-line dir))
4101 (if (not 4122 (if (looking-at (rst-re 'ttl-beg-1)) ; title found, i.e.
4102 (looking-at (rst-re 'ado-beg-2-1))) ; no overline / 4123 ; underline / overline
4103 ; underline. 4124 ; found.
4104 (rst-forward-line (- dir)))))) ; step back to line. 4125 (if (zerop (rst-forward-line dir))
4105 (if (not (= (point) pt)) 4126 (if (not
4106 (point)))))) 4127 (looking-at (rst-re 'ado-beg-2-1))) ; no
4128 ; overline
4129 ; /
4130 ; underline.
4131 (rst-forward-line (- dir)))) ; step back to
4132 ; title /
4133 ; adornment.
4134 (if (< dir 0) ; keep downward adornment.
4135 (rst-forward-line (- dir))))) ; step back to adornment.
4136 (if (looking-at (rst-re 'ttl-beg-1)) ; may be a title.
4137 (if (zerop (rst-forward-line dir))
4138 (if (not
4139 (looking-at (rst-re 'ado-beg-2-1))) ; no overline /
4140 ; underline.
4141 (rst-forward-line (- dir)))))) ; step back to line.
4142 (if (not (= (point) pt))
4143 (point)))))))
4107 4144
4108;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4145;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4109;; Indented blocks 4146;; Indented blocks
4110 4147
4111(defun rst-forward-indented-block (&optional column limit) 4148(defun rst-forward-indented-block (&optional column limit)
4149 ;; testcover: ok.
4112 "Move forward across one indented block. 4150 "Move forward across one indented block.
4113Find the next non-empty line which is not indented at least to COLUMN (defaults 4151Find the next non-empty line which is not indented at least to
4114to the column of the point). Moves point to first character of this line or the 4152COLUMN (defaults to the column of the point). Moves point to
4115first empty line immediately before it and returns that position. If there is 4153first character of this line or the first of the empty lines
4116no such line before LIMIT (defaults to the end of the buffer) returns nil and 4154immediately before it and returns that position. If there is no
4117point is not moved." 4155such line before LIMIT (defaults to the end of the buffer)
4118 (interactive) 4156returns nil and point is not moved."
4119 (let ((clm (or column (current-column))) 4157 (let (fnd candidate)
4120 (start (point)) 4158 (setq fnd (rst-apply-indented-blocks
4121 fnd beg cand) 4159 (point) (or limit (point-max)) (or column (current-column))
4122 (if (not limit) 4160 #'(lambda (_count _in-first _in-sub in-super in-empty _relind)
4123 (setq limit (point-max))) 4161 (cond
4124 (save-match-data 4162 (in-empty
4125 (while (and (not fnd) (< (point) limit)) 4163 (setq candidate (or candidate (line-beginning-position)))
4126 (forward-line 1) 4164 nil)
4127 (when (< (point) limit) 4165 (in-super
4128 (setq beg (point)) 4166 (or candidate (line-beginning-position)))
4129 (if (looking-at (rst-re 'lin-end)) 4167 (t ; Non-empty, same or more indented line.
4130 (setq cand (or cand beg)) ; An empty line is a candidate. 4168 (setq candidate nil)
4131 (move-to-column clm) 4169 nil)))))
4132 ;; FIXME: No indentation [(zerop clm)] must be handled in some 4170 (when fnd
4133 ;; useful way - though it is not clear what this should mean 4171 (goto-char fnd))))
4134 ;; at all.
4135 (if (string-match
4136 (rst-re 'linemp-tag)
4137 (buffer-substring-no-properties beg (point)))
4138 (setq cand nil) ; An indented line resets a candidate.
4139 (setq fnd (or cand beg)))))))
4140 (goto-char (or fnd start))
4141 fnd))
4142 4172
4143(defvar rst-font-lock-find-unindented-line-begin nil 4173(defvar rst-font-lock-find-unindented-line-begin nil
4144 "Beginning of the match if `rst-font-lock-find-unindented-line-end'.") 4174 "Beginning of the match if `rst-font-lock-find-unindented-line-end'.")
@@ -4156,42 +4186,43 @@ IND-PNT is non-nil but not a number take the indentation from the
4156next non-empty line if this is indented more than the current one." 4186next non-empty line if this is indented more than the current one."
4157 (setq rst-font-lock-find-unindented-line-begin ind-pnt) 4187 (setq rst-font-lock-find-unindented-line-begin ind-pnt)
4158 (setq rst-font-lock-find-unindented-line-end 4188 (setq rst-font-lock-find-unindented-line-end
4159 (save-excursion 4189 (save-match-data
4160 (when (not (numberp ind-pnt)) 4190 (save-excursion
4161 ;; Find indentation point in next line if any. 4191 (when (not (numberp ind-pnt))
4162 (setq ind-pnt 4192 ;; Find indentation point in next line if any.
4163 ;; FIXME: Should be refactored to two different functions 4193 (setq ind-pnt
4164 ;; giving their result to this function, may be 4194 ;; FIXME: Should be refactored to two different functions
4165 ;; integrated in caller. 4195 ;; giving their result to this function, may be
4166 (save-match-data 4196 ;; integrated in caller.
4167 (let ((cur-ind (current-indentation))) 4197 (save-match-data
4168 (if (eq ind-pnt 'next) 4198 (let ((cur-ind (current-indentation)))
4169 (when (and (zerop (forward-line 1)) 4199 (if (eq ind-pnt 'next)
4170 (< (point) (point-max))) 4200 (when (and (rst-forward-line-strict 1 (point-max))
4171 ;; Not at EOF. 4201 (< (point) (point-max)))
4172 (setq rst-font-lock-find-unindented-line-begin 4202 ;; Not at EOF.
4173 (point)) 4203 (setq rst-font-lock-find-unindented-line-begin
4174 (when (and (not (looking-at (rst-re 'lin-end))) 4204 (point))
4175 (> (current-indentation) cur-ind)) 4205 (when (and (not (looking-at (rst-re 'lin-end)))
4206 (> (current-indentation) cur-ind))
4176 ;; Use end of indentation if non-empty line. 4207 ;; Use end of indentation if non-empty line.
4177 (looking-at (rst-re 'hws-tag)) 4208 (looking-at (rst-re 'hws-tag))
4178 (match-end 0))) 4209 (match-end 0)))
4179 ;; Skip until non-empty line or EOF. 4210 ;; Skip until non-empty line or EOF.
4180 (while (and (zerop (forward-line 1)) 4211 (while (and (rst-forward-line-strict 1 (point-max))
4181 (< (point) (point-max)) 4212 (< (point) (point-max))
4182 (looking-at (rst-re 'lin-end)))) 4213 (looking-at (rst-re 'lin-end))))
4183 (when (< (point) (point-max)) 4214 (when (< (point) (point-max))
4184 ;; Not at EOF. 4215 ;; Not at EOF.
4185 (setq rst-font-lock-find-unindented-line-begin 4216 (setq rst-font-lock-find-unindented-line-begin
4186 (point)) 4217 (point))
4187 (when (> (current-indentation) cur-ind) 4218 (when (> (current-indentation) cur-ind)
4188 ;; Indentation bigger than line of departure. 4219 ;; Indentation bigger than line of departure.
4189 (looking-at (rst-re 'hws-tag)) 4220 (looking-at (rst-re 'hws-tag))
4190 (match-end 0)))))))) 4221 (match-end 0))))))))
4191 (when ind-pnt 4222 (when ind-pnt
4192 (goto-char ind-pnt) 4223 (goto-char ind-pnt)
4193 (or (rst-forward-indented-block nil (point-max)) 4224 (or (rst-forward-indented-block nil (point-max))
4194 (point-max)))))) 4225 (point-max)))))))
4195 4226
4196(defun rst-font-lock-find-unindented-line-match (_limit) 4227(defun rst-font-lock-find-unindented-line-match (_limit)
4197 "Set the match found earlier if match were found. 4228 "Set the match found earlier if match were found.
@@ -4359,33 +4390,31 @@ select the alternative tool-set."
4359 (interactive "P") 4390 (interactive "P")
4360 ;; Note: maybe we want to check if there is a Makefile too and not do anything 4391 ;; Note: maybe we want to check if there is a Makefile too and not do anything
4361 ;; if that is the case. I dunno. 4392 ;; if that is the case. I dunno.
4362 (let* ((toolset (cdr (assq (if use-alt 4393 (cl-destructuring-bind
4363 rst-compile-secondary-toolset 4394 (command extension options
4364 rst-compile-primary-toolset) 4395 &aux (conffile (rst-compile-find-conf))
4365 rst-compile-toolsets))) 4396 (bufname (file-name-nondirectory buffer-file-name)))
4366 (command (car toolset)) 4397 (cdr (assq (if use-alt
4367 (extension (cadr toolset)) 4398 rst-compile-secondary-toolset
4368 (options (caddr toolset)) 4399 rst-compile-primary-toolset)
4369 (conffile (rst-compile-find-conf)) 4400 rst-compile-toolsets))
4370 (bufname (file-name-nondirectory buffer-file-name))
4371 (outname (file-name-sans-extension bufname)))
4372
4373 ;; Set compile-command before invocation of compile. 4401 ;; Set compile-command before invocation of compile.
4374 (setq-local 4402 (setq-local
4375 compile-command 4403 compile-command
4376 (mapconcat 'identity 4404 (mapconcat
4377 (list command 4405 #'identity
4378 (or options "") 4406 (list command
4379 (if conffile 4407 (or options "")
4380 (concat "--config=" (shell-quote-argument conffile)) 4408 (if conffile
4381 "") 4409 (concat "--config=" (shell-quote-argument conffile))
4382 (shell-quote-argument bufname) 4410 "")
4383 (shell-quote-argument (concat outname extension))) 4411 (shell-quote-argument bufname)
4384 " ")) 4412 (shell-quote-argument (concat (file-name-sans-extension bufname)
4385 4413 extension)))
4414 " "))
4386 ;; Invoke the compile command. 4415 ;; Invoke the compile command.
4387 (if (or compilation-read-command use-alt) 4416 (if (or compilation-read-command use-alt)
4388 (call-interactively 'compile) 4417 (call-interactively #'compile)
4389 (compile compile-command)))) 4418 (compile compile-command))))
4390 4419
4391(defun rst-compile-alt-toolset () 4420(defun rst-compile-alt-toolset ()
@@ -4443,6 +4472,10 @@ buffer, if the region is not selected."
4443 4472
4444;; FIXME: Add `rst-compile-html-preview'. 4473;; FIXME: Add `rst-compile-html-preview'.
4445 4474
4475;; FIXME: Add support for `restview` (http://mg.pov.lt/restview/). May be a
4476;; more general facility for calling commands on a reST file would make
4477;; sense.
4478
4446 4479
4447;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4480;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4448;; Imenu support 4481;; Imenu support
@@ -4470,12 +4503,12 @@ buffer, if the region is not selected."
4470 ;; become visible even for long title lines. May be an additional 4503 ;; become visible even for long title lines. May be an additional
4471 ;; level number is also useful. 4504 ;; level number is also useful.
4472 (setq name (format "%s%s%s" pfx txt sfx)) 4505 (setq name (format "%s%s%s" pfx txt sfx))
4473 (cons name ;; The name of the entry. 4506 (cons name ; The name of the entry.
4474 (if children 4507 (if children
4475 (cons ;; The entry has a submenu. 4508 (cons ; The entry has a submenu.
4476 (cons name pos) ;; The entry itself. 4509 (cons name pos) ; The entry itself.
4477 (mapcar 'rst-imenu-convert-cell children)) ;; The children. 4510 (mapcar #'rst-imenu-convert-cell children)) ; The children.
4478 pos)))) ;; The position of a plain entry. 4511 pos)))) ; The position of a plain entry.
4479 4512
4480;; FIXME: Document title and subtitle need to be handled properly. They should 4513;; FIXME: Document title and subtitle need to be handled properly. They should
4481;; get an own "Document" top level entry. 4514;; get an own "Document" top level entry.
@@ -4485,7 +4518,7 @@ Return as described for `imenu--index-alist'."
4485 (rst-reset-section-caches) 4518 (rst-reset-section-caches)
4486 (let ((root (rst-all-stn))) 4519 (let ((root (rst-all-stn)))
4487 (when root 4520 (when root
4488 (mapcar 'rst-imenu-convert-cell (rst-Stn-children root))))) 4521 (mapcar #'rst-imenu-convert-cell (rst-Stn-children root)))))
4489 4522
4490 4523
4491;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4524;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -4504,7 +4537,7 @@ cand replace with char: ")
4504 (setq found (1+ found)) 4537 (setq found (1+ found))
4505 (goto-char (match-beginning 1)) 4538 (goto-char (match-beginning 1))
4506 (let ((width (current-column))) 4539 (let ((width (current-column)))
4507 (rst-delete-entire-line) 4540 (rst-delete-entire-line 0)
4508 (insert-char tochar width))) 4541 (insert-char tochar width)))
4509 (message "%d lines replaced." found)))) 4542 (message "%d lines replaced." found))))
4510 4543
@@ -4513,7 +4546,7 @@ cand replace with char: ")
4513 "Join lines in current paragraph into one line, removing end-of-lines." 4546 "Join lines in current paragraph into one line, removing end-of-lines."
4514 (interactive) 4547 (interactive)
4515 (let ((fill-column 65000)) ; Some big number. 4548 (let ((fill-column 65000)) ; Some big number.
4516 (call-interactively 'fill-paragraph))) 4549 (call-interactively #'fill-paragraph)))
4517 4550
4518;; FIXME: Unbound command - should be bound or removed. 4551;; FIXME: Unbound command - should be bound or removed.
4519(defun rst-force-fill-paragraph () 4552(defun rst-force-fill-paragraph ()