[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] master 9ed3685: Lots of refactorings and a few minor impro
|
From: |
Stefan Merten |
|
Subject: |
[Emacs-diffs] master 9ed3685: Lots of refactorings and a few minor improvements. |
|
Date: |
Tue, 3 Jan 2017 22:15:41 +0000 (UTC) |
branch: master
commit 9ed3685a778843cbc0df3ca2490f79eb4e2ebefe
Author: Stefan Merten <address@hidden>
Commit: Stefan Merten <address@hidden>
Lots of refactorings and a few minor improvements.
User visible improvements and changes:
* Improve and debug `rst-forward-section` and `rst-backward-section`.
* Auto-enumeration may be used with all styles for list insertion.
* Improve and debug `rst-toc-insert`.
* Adapt change in Emacs to use customization group `text` instead of `wp`.
* Bind `n` and `p` in `rst-toc-mode`.
* `z` in `toc-mode` returns to the previous window configuration.
* Require Emacs version >= 24.1.
Lots of refactorings including:
* Silence byte compiler.
* Use lexical binding.
* Use `cl-lib`.
* Add tests and raise test coverage.
---
lisp/textmodes/rst.el | 3153 +++++++++++++++++++++++++------------------------
1 file changed, 1593 insertions(+), 1560 deletions(-)
diff --git a/lisp/textmodes/rst.el b/lisp/textmodes/rst.el
index 90c1f45..edc4885 100644
--- a/lisp/textmodes/rst.el
+++ b/lisp/textmodes/rst.el
@@ -1,4 +1,4 @@
-;;; rst.el --- Mode for viewing and editing reStructuredText-documents.
+;;; rst.el --- Mode for viewing and editing reStructuredText-documents -*-
lexical-binding: t -*-
;; Copyright (C) 2003-2017 Free Software Foundation, Inc.
@@ -100,15 +100,30 @@
;; FIXME: Check through major mode conventions again.
-;; FIXME: Add proper ";;;###autoload" comments.
-
-;; FIXME: When 24.1 is common place remove use of `lexical-let' and put "-*-
-;; lexical-binding: t -*-" in the first line.
-
;; FIXME: Embed complicated `defconst's in `eval-when-compile'.
-;; FIXME: Use `testcover'. Mark up a function with sufficient test coverage by
-;; a comment tagged with `testcover' after the `defun'.
+;; Common Lisp stuff
+(require 'cl-lib)
+
+;; Correct wrong declaration.
+(def-edebug-spec push
+ (&or [form symbolp] [form gv-place]))
+
+;; Correct wrong declaration. This still doesn't support dotted desctructuring
+;; though.
+(def-edebug-spec cl-lambda-list
+ (([&rest cl-macro-arg]
+ [&optional ["&optional" cl-&optional-arg &rest cl-&optional-arg]]
+ [&optional ["&rest" arg]]
+ [&optional ["&key" [cl-&key-arg &rest cl-&key-arg]
+ &optional "&allow-other-keys"]]
+ [&optional ["&aux" &rest
+ &or (symbolp &optional def-form) symbolp]]
+ )))
+
+;; Add missing declaration.
+(def-edebug-spec cl-type-spec sexp) ;; This is not exactly correct but good
+ ;; enough.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Support for `testcover'
@@ -129,9 +144,9 @@ considered constants. Revert it with this function after
each `defcustom'."
(setq testcover-module-constants
(delq nil
(mapcar
- (lambda (sym)
- (if (not (plist-member (symbol-plist sym) 'standard-value))
- sym))
+ #'(lambda (sym)
+ (if (not (plist-member (symbol-plist sym) 'standard-value))
+ sym))
testcover-module-constants)))))
(defun rst-testcover-add-compose (fun)
@@ -144,69 +159,72 @@ considered constants. Revert it with this function after
each `defcustom'."
(when (boundp 'testcover-1value-functions)
(add-to-list 'testcover-1value-functions fun)))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Common Lisp stuff
-
-;; Only use of macros is allowed - may be replaced by `cl-lib' some time.
-(eval-when-compile
- (require 'cl))
-
-;; Redefine some functions from `cl.el' in a proper namespace until they may be
-;; used from there.
-
-(defun rst-signum (x)
+;; Helpers.
+
+(cl-defmacro rst-destructuring-dolist
+ ((arglist list &optional result) &rest body)
+ "`cl-dolist' with destructuring of the list elements.
+ARGLIST is a Common List argument list which may include
+destructuring. LIST, RESULT and BODY are as for `cl-dolist'.
+Note that definitions in ARGLIST are visible only in the BODY and
+neither in RESULT nor in LIST."
+ ;; FIXME: It would be very useful if the definitions in ARGLIST would be
+ ;; visible in RESULT. But may be this is rather a
+ ;; `rst-destructuring-do' then.
+ (declare (debug
+ (&define ([&or symbolp cl-macro-list] def-form &optional def-form)
+ cl-declarations def-body))
+ (indent 1))
+ (let ((var (make-symbol "--rst-destructuring-dolist-var--")))
+ `(cl-dolist (,var ,list ,result)
+ (cl-destructuring-bind ,arglist ,var
+ ,@body))))
+
+(defun rst-forward-line-strict (n &optional limit)
;; testcover: ok.
- "Return 1 if X is positive, -1 if negative, 0 if zero."
- (cond
- ((> x 0) 1)
- ((< x 0) -1)
- (t 0)))
-
-(defun rst-some (seq &optional pred)
- ;; testcover: ok.
- "Return non-nil if any element of SEQ yields non-nil when PRED is applied.
-Apply PRED to each element of list SEQ until the first non-nil
-result is yielded and return this result. PRED defaults to
-`identity'."
- (unless pred
- (setq pred 'identity))
- (catch 'rst-some
- (dolist (elem seq)
- (let ((r (funcall pred elem)))
- (when r
- (throw 'rst-some r))))))
-
-(defun rst-position-if (pred seq)
- ;; testcover: ok.
- "Return position of first element satisfying PRED in list SEQ or nil."
- (catch 'rst-position-if
- (let ((i 0))
- (dolist (elem seq)
- (when (funcall pred elem)
- (throw 'rst-position-if i))
- (incf i)))))
-
-(defun rst-position (elem seq)
+ "Try to move point to beginning of line I + N where I is the current line.
+Return t if movement is successful. Otherwise don't move point
+and return nil. If a position is given by LIMIT, movement
+happened but the following line is missing and thus its beginning
+can not be reached but the movement reached at least LIMIT
+consider this a successful movement. LIMIT is ignored in other
+cases."
+ (let ((start (point)))
+ (if (and (zerop (forward-line n))
+ (or (bolp)
+ (and limit
+ (>= (point) limit))))
+ t
+ (goto-char start)
+ nil)))
+
+(defun rst-forward-line-looking-at (n rst-re-args &optional fun)
;; testcover: ok.
- "Return position of ELEM in list SEQ or nil.
-Comparison done with `equal'."
- ;; Create a closure containing `elem' so the `lambda' always sees our
- ;; parameter instead of an `elem' which may be in dynamic scope at the time
- ;; of execution of the `lambda'.
- (lexical-let ((elem elem))
- (rst-position-if (function (lambda (e)
- (equal elem e)))
- seq)))
-
-(defun rst-member-if (pred seq)
- ;; testcover: ok.
- "Return sublist of SEQ starting with the element whose car satisfies PRED."
- (let (found)
- (while (and (not found) seq)
- (if (funcall pred (car seq))
- (setq found seq)
- (setq seq (cdr seq))))
- found))
+ "Move forward N lines and if successful check whether RST-RE-ARGS is matched.
+Moving forward is done by `rst-forward-line-strict'. RST-RE-ARGS
+is a single or a list of arguments for `rst-re'. FUN is a
+function defaulting to `identity' which is called after the call
+to `looking-at' receiving its return value as the first argument.
+When FUN is called match data is just set by `looking-at' and
+point is at the beginning of the line. Return nil if moving
+forward failed or otherwise the return value of FUN. Preserve
+global match data, point, mark and current buffer."
+ (unless (listp rst-re-args)
+ (setq rst-re-args (list rst-re-args)))
+ (unless fun
+ (setq fun #'identity))
+ (save-match-data
+ (save-excursion
+ (when (rst-forward-line-strict n)
+ (funcall fun (looking-at (apply #'rst-re rst-re-args)))))))
+
+(rst-testcover-add-1value 'rst-delete-entire-line)
+(defun rst-delete-entire-line (n)
+ "Move N lines and delete the entire line."
+ (delete-region (line-beginning-position (+ n 1))
+ (line-beginning-position (+ n 2))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -226,7 +244,7 @@ and before TAIL-RE and DELIM-RE in VAR or DEFAULT for no
match."
;; Use CVSHeader to really get information from CVS and not other version
;; control systems.
(defconst rst-cvs-header
- "$CVSHeader: sm/rst_el/rst.el,v 1.600 2016/07/31 11:13:44 stefan Exp $")
+ "$CVSHeader: sm/rst_el/rst.el,v 1.1058.2.3 2017/01/03 21:56:29 stefan Exp $")
(defconst rst-cvs-rev
(rst-extract-version "\\$" "CVSHeader: \\S + " "[0-9]+\\(?:\\.[0-9]+\\)+"
" .*" rst-cvs-header "0.0")
@@ -240,22 +258,22 @@ and before TAIL-RE and DELIM-RE in VAR or DEFAULT for no
match."
;; Use LastChanged... to really get information from SVN.
(defconst rst-svn-rev
(rst-extract-version "\\$" "LastChangedRevision: " "[0-9]+" " "
- "$LastChangedRevision: 7963 $")
+ "$LastChangedRevision: 8011 $")
"The SVN revision of this file.
SVN revision is the upstream (docutils) revision.")
(defconst rst-svn-timestamp
(rst-extract-version "\\$" "LastChangedDate: " ".+?+" " "
- "$LastChangedDate: 2016-07-31 13:13:21 +0200 (Sun, 31
Jul 2016) $")
+ "$LastChangedDate: 2017-01-03 22:56:17 +0100 (Tue, 03
Jan 2017) $")
"The SVN time stamp of this file.")
;; Maintained by the release process.
(defconst rst-official-version
(rst-extract-version "%" "OfficialVersion: " "[0-9]+\\(?:\\.[0-9]+\\)+" " "
- "%OfficialVersion: 1.5.0 %")
+ "%OfficialVersion: 1.5.1 %")
"Official version of the package.")
(defconst rst-official-cvs-rev
(rst-extract-version "[%$]" "Revision: " "[0-9]+\\(?:\\.[0-9]+\\)+" " "
- "%Revision: 1.600 %")
+ "$Revision: 1.1058.2.3 $")
"CVS revision of this file in the official version.")
(defconst rst-version
@@ -278,6 +296,7 @@ in parentheses follows the development revision and the
time stamp.")
("1.4.1" . "24.5")
("1.4.2" . "24.5")
("1.5.0" . "26.1")
+ ("1.5.1" . "26.2")
))
(unless (assoc rst-official-version rst-package-emacs-version-alist)
@@ -368,6 +387,7 @@ in parentheses follows the development revision and the
time stamp.")
;; Various starts
(bul-sta bul-tag bli-sfx) ; Start of a bulleted item.
+ (bul-beg lin-beg bul-sta) ; A bullet item at the beginning of a line.
;; Explicit markup tag (`exm')
(exm-tag "\\.\\.")
@@ -571,34 +591,34 @@ referenceable group (\"\\(...\\)\").
After interpretation of ARGS the results are concatenated as for
`:seq'."
- (apply 'concat
+ (apply #'concat
(mapcar
- (lambda (re)
- (cond
- ((stringp re)
- re)
- ((symbolp re)
- (cadr (assoc re rst-re-alist)))
- ((characterp re)
- (regexp-quote (char-to-string re)))
- ((listp re)
- (let ((nested
- (mapcar (lambda (elt)
- (rst-re elt))
- (cdr re))))
- (cond
- ((eq (car re) :seq)
- (mapconcat 'identity nested ""))
- ((eq (car re) :shy)
- (concat "\\(?:" (mapconcat 'identity nested "") "\\)"))
- ((eq (car re) :grp)
- (concat "\\(" (mapconcat 'identity nested "") "\\)"))
- ((eq (car re) :alt)
- (concat "\\(?:" (mapconcat 'identity nested "\\|") "\\)"))
- (t
- (error "Unknown list car: %s" (car re))))))
- (t
- (error "Unknown object type for building regex: %s" re))))
+ #'(lambda (re)
+ (cond
+ ((stringp re)
+ re)
+ ((symbolp re)
+ (cadr (assoc re rst-re-alist)))
+ ((characterp re)
+ (regexp-quote (char-to-string re)))
+ ((listp re)
+ (let ((nested
+ (mapcar (lambda (elt)
+ (rst-re elt))
+ (cdr re))))
+ (cond
+ ((eq (car re) :seq)
+ (mapconcat #'identity nested ""))
+ ((eq (car re) :shy)
+ (concat "\\(?:" (mapconcat #'identity nested "") "\\)"))
+ ((eq (car re) :grp)
+ (concat "\\(" (mapconcat #'identity nested "") "\\)"))
+ ((eq (car re) :alt)
+ (concat "\\(?:" (mapconcat #'identity nested "\\|") "\\)"))
+ (t
+ (error "Unknown list car: %s" (car re))))))
+ (t
+ (error "Unknown object type for building regex: %s" re))))
args)))
;; 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
(dolist (re rst-re-alist-def rst-re-alist)
(setq rst-re-alist
(nconc rst-re-alist
- (list (list (car re) (apply 'rst-re (cdr re))))))))
+ (list (list (car re) (apply #'rst-re (cdr re))))))))
"Alist mapping symbols from `rst-re-alist-def' to regex strings."))
@@ -630,9 +650,9 @@ After interpretation of ARGS the results are concatenated
as for
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Class rst-Ado
-(defstruct
+(cl-defstruct
(rst-Ado
- (:constructor nil) ;; Prevent creating unchecked values.
+ (:constructor nil) ; Prevent creating unchecked values.
;; Construct a transition.
(:constructor
rst-Ado-new-transition
@@ -682,61 +702,45 @@ This type is immutable."
;; testcover: ok.
"Validate CHAR to be a valid adornment character.
Return CHAR if so or signal an error otherwise."
- (cond
- ((not (characterp char))
- (signal 'wrong-type-argument (list 'characterp char)))
- ((memq char rst-adornment-chars)
- char)
- (t
- (signal 'args-out-of-range
- (list (format
- "Character must be a valid adornment character, not '%s'"
- char))))))
+ (cl-check-type char character)
+ (cl-check-type char (satisfies
+ (lambda (c)
+ (memq c rst-adornment-chars)))
+ "Character must be a valid adornment character")
+ char)
;; Public methods
(defun rst-Ado-is-transition (self)
;; testcover: ok.
"Return non-nil if SELF is a transition adornment."
- (unless (rst-Ado-p self)
- (signal 'wrong-type-argument
- (list 'rst-Ado-p self)))
+ (cl-check-type self rst-Ado)
(eq (rst-Ado--style self) 'transition))
(defun rst-Ado-is-section (self)
;; testcover: ok.
"Return non-nil if SELF is a section adornment."
- (unless (rst-Ado-p self)
- (signal 'wrong-type-argument
- (list 'rst-Ado-p self)))
+ (cl-check-type self rst-Ado)
(not (rst-Ado-is-transition self)))
(defun rst-Ado-is-simple (self)
;; testcover: ok.
"Return non-nil if SELF is a simple section adornment."
- (unless (rst-Ado-p self)
- (signal 'wrong-type-argument
- (list 'rst-Ado-p self)))
+ (cl-check-type self rst-Ado)
(eq (rst-Ado--style self) 'simple))
(defun rst-Ado-is-over-and-under (self)
;; testcover: ok.
"Return non-nil if SELF is a over-and-under section adornment."
- (unless (rst-Ado-p self)
- (signal 'wrong-type-argument
- (list 'rst-Ado-p self)))
+ (cl-check-type self rst-Ado)
(eq (rst-Ado--style self) 'over-and-under))
(defun rst-Ado-equal (self other)
;; testcover: ok.
"Return non-nil when SELF and OTHER are equal."
+ (cl-check-type self rst-Ado)
+ (cl-check-type other rst-Ado)
(cond
- ((not (rst-Ado-p self))
- (signal 'wrong-type-argument
- (list 'rst-Ado-p self)))
- ((not (rst-Ado-p other))
- (signal 'wrong-type-argument
- (list 'rst-Ado-p other)))
((not (eq (rst-Ado--style self) (rst-Ado--style other)))
nil)
((rst-Ado-is-transition self))
@@ -744,22 +748,19 @@ Return CHAR if so or signal an error otherwise."
(defun rst-Ado-position (self ados)
;; testcover: ok.
- "Return position of of SELF in ADOS or nil."
- (unless (rst-Ado-p self)
- (signal 'wrong-type-argument
- (list 'rst-Ado-p self)))
- (lexical-let ((ado self)) ;; Create closure.
- (rst-position-if (function (lambda (e)
- (rst-Ado-equal ado e)))
- ados)))
+ "Return position of SELF in ADOS or nil."
+ (cl-check-type self rst-Ado)
+ (cl-position-if #'(lambda (e)
+ (rst-Ado-equal self e))
+ ados))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Class rst-Hdr
-(defstruct
+(cl-defstruct
(rst-Hdr
- (:constructor nil) ;; Prevent creating unchecked values.
+ (:constructor nil) ; Prevent creating unchecked values.
;; Construct while all parameters must be valid.
(:constructor
rst-Hdr-new
@@ -784,7 +785,7 @@ Return CHAR if so or signal an error otherwise."
&aux
(ado (rst-Hdr--validate-ado (rst-Ado-new-invert ado-arg)))
(indent (rst-Hdr--validate-indent indent-arg ado t))))
- (:copier rst-Hdr-copy)) ;; Not really needed for an immutable type.
+ (:copier nil)) ; Not really needed for an immutable type.
"Representation of reStructuredText section header characteristics.
This type is immutable."
@@ -800,10 +801,8 @@ This type is immutable."
"Validate INDENT to be a valid indentation for ADO.
Return INDENT if so or signal an error otherwise. If LAX don't
signal an error and return a valid indent."
+ (cl-check-type indent integer)
(cond
- ((not (integerp indent))
- (signal 'wrong-type-argument
- (list 'integerp 'null indent)))
((zerop indent)
indent)
((rst-Ado-is-simple ado)
@@ -816,33 +815,34 @@ signal an error and return a valid indent."
0
(signal 'args-out-of-range
'("Indentation must not be negative"))))
- (indent))) ;; Implicitly over-and-under.
+ ;; Implicitly over-and-under.
+ (indent)))
(defun rst-Hdr--validate-ado (ado)
;; testcover: ok.
"Validate ADO to be a valid adornment.
Return ADO if so or signal an error otherwise."
+ (cl-check-type ado rst-Ado)
(cond
- ((not (rst-Ado-p ado))
- (signal 'wrong-type-argument
- (list 'rst-Ado-p ado)))
((rst-Ado-is-transition ado)
(signal 'args-out-of-range
'("Adornment for header must not be transition.")))
- (t
- ado)))
+ (ado)))
;; Public class methods
+(defvar rst-preferred-adornments) ; Forward declaration.
+
(defun rst-Hdr-preferred-adornments ()
;; testcover: ok.
"Return preferred adornments as list of `rst-Hdr'."
- (mapcar (lambda (el)
- (rst-Hdr-new-lax
- (if (eq (cadr el) 'over-and-under)
- (rst-Ado-new-over-and-under (car el))
- (rst-Ado-new-simple (car el)))
- (caddr el)))
+ (mapcar (cl-function
+ (lambda ((character style indent))
+ (rst-Hdr-new-lax
+ (if (eq style 'over-and-under)
+ (rst-Ado-new-over-and-under character)
+ (rst-Ado-new-simple character))
+ indent)))
rst-preferred-adornments))
;; Public methods
@@ -850,238 +850,238 @@ Return ADO if so or signal an error otherwise."
(defun rst-Hdr-member-ado (self hdrs)
;; testcover: ok.
"Return sublist of HDRS whose car's adornment equals that of SELF or nil."
- (unless (rst-Hdr-p self)
- (signal 'wrong-type-argument
- (list 'rst-Hdr-p self)))
- (let ((pos (rst-Ado-position (rst-Hdr-ado self) (rst-Hdr-ado-map hdrs))))
- (and pos (nthcdr pos hdrs))))
+ (cl-check-type self rst-Hdr)
+ (let ((ado (rst-Hdr-ado self)))
+ (cl-member-if #'(lambda (hdr)
+ (rst-Ado-equal ado (rst-Hdr-ado hdr)))
+ hdrs)))
(defun rst-Hdr-ado-map (selves)
;; testcover: ok.
"Return `rst-Ado' list extracted from elements of SELVES."
- (mapcar 'rst-Hdr-ado selves))
+ (mapcar #'rst-Hdr-ado selves))
(defun rst-Hdr-get-char (self)
;; testcover: ok.
"Return character of the adornment of SELF."
- (unless (rst-Hdr-p self)
- (signal 'wrong-type-argument
- (list 'rst-Hdr-p self)))
+ (cl-check-type self rst-Hdr)
(rst-Ado-char (rst-Hdr-ado self)))
(defun rst-Hdr-is-over-and-under (self)
;; testcover: ok.
"Return non-nil if SELF is a over-and-under section header."
- (unless (rst-Hdr-p self)
- (signal 'wrong-type-argument
- (list 'rst-Hdr-p self)))
+ (cl-check-type self rst-Hdr)
(rst-Ado-is-over-and-under (rst-Hdr-ado self)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Class rst-Ttl
-(defstruct
+(cl-defstruct
(rst-Ttl
- (:constructor nil) ;; Prevent creating unchecked values.
+ (:constructor nil) ; Prevent creating unchecked values.
;; Construct with valid parameters for all attributes.
- (:constructor
- rst-Ttl-new
+ (:constructor ; Private constructor
+ rst-Ttl--new
(ado-arg
match-arg
indent-arg
text-arg
- &optional
- hdr-arg
- level-arg
&aux
(ado (rst-Ttl--validate-ado ado-arg))
(match (rst-Ttl--validate-match match-arg ado))
(indent (rst-Ttl--validate-indent indent-arg ado))
(text (rst-Ttl--validate-text text-arg ado))
- (hdr (and hdr-arg (rst-Ttl--validate-hdr hdr-arg ado indent)))
- (level (and level-arg (rst-Ttl--validate-level level-arg)))))
- (:copier rst-Ttl-copy))
- "Representation of a reStructuredText section header as found in the buffer.
-This type gathers information about an adorned part in the
-buffer. Thus only the basic attributes are immutable. Although
-the remaining attributes are `setf'-able the respective setters
-should be used."
+ (hdr (condition-case nil
+ (rst-Hdr-new ado indent)
+ (error nil)))))
+ (:copier nil)) ; Not really needed for an immutable type.
+ "Representation of a reStructuredText section header as found in a buffer.
+This type gathers information about an adorned part in the buffer.
+
+This type is immutable."
;; The adornment characteristics or nil for a title candidate.
(ado nil :read-only t)
- ;; The match-data for `ado' as returned by `match-data'. Match group 0
- ;; matches the whole construct. Match group 1 matches the overline adornment
- ;; if present. Match group 2 matches the section title text or the
- ;; transition. Match group 3 matches the underline adornment.
+ ;; The match-data for `ado' in a form similarly returned by `match-data' (but
+ ;; not necessarily with markers in buffers). Match group 0 matches the whole
+ ;; construct. Match group 1 matches the overline adornment if present.
+ ;; Match group 2 matches the section title text or the transition. Match
+ ;; group 3 matches the underline adornment.
(match nil :read-only t)
;; An indentation found for the title line or nil for a transition.
(indent nil :read-only t)
;; The text of the title or nil for a transition.
(text nil :read-only t)
;; The header characteristics if it is a valid section header.
- (hdr nil)
- ;; The hierarchical level of the section header starting with 0.
- (level nil))
+ (hdr nil :read-only t)
+ ;; FIXME refactoring: Should have an attribute `buffer' for the buffer this
+ ;; title is found in. This breaks lots and lots of tests.
+ ;; However, with private constructor they may not be
+ ;; necessary any more. In case it is really a buffer then
+ ;; also `match' could be real data from `match-data' which
+ ;; contains markers instead of integers.
+ )
;; Private class methods
(defun rst-Ttl--validate-ado (ado)
;; testcover: ok.
"Return valid ADO or signal error."
- (unless (or (null ado) (rst-Ado-p ado))
- (signal 'wrong-type-argument
- (list 'null 'rst-Ado-p ado)))
+ (cl-check-type ado (or null rst-Ado))
ado)
(defun rst-Ttl--validate-match (match ado)
;; testcover: ok.
"Return valid MATCH matching ADO or signal error."
- (unless (listp match)
- (signal 'wrong-type-argument
- (list 'listp match)))
- (unless (equal (length match) 8)
- (signal 'args-out-of-range
- '("Match data must consist of exactly 8 buffer positions.")))
- (mapcar (lambda (pos)
- (unless (or (null pos) (integer-or-marker-p pos))
- (signal 'wrong-type-argument
- (list 'integer-or-marker-p 'null pos))))
- match)
- (unless (and (integer-or-marker-p (nth 0 match))
- (integer-or-marker-p (nth 1 match)))
- (signal 'args-out-of-range
- '("First two elements of match data must be buffer positions.")))
- (cond
- ((null ado)
- (unless (and (null (nth 2 match))
- (null (nth 3 match))
- (integer-or-marker-p (nth 4 match))
- (integer-or-marker-p (nth 5 match))
- (null (nth 6 match))
- (null (nth 7 match)))
- (signal 'args-out-of-range
- '("For a title candidate exactly the third match pair must be
set."))))
- ((rst-Ado-is-transition ado)
- (unless (and (null (nth 2 match))
- (null (nth 3 match))
- (integer-or-marker-p (nth 4 match))
- (integer-or-marker-p (nth 5 match))
- (null (nth 6 match))
- (null (nth 7 match)))
+ (cl-check-type ado (or null rst-Ado))
+ (cl-check-type match list)
+ (cl-check-type match (satisfies (lambda (m)
+ (equal (length m) 8)))
+ "Match data must consist of exactly 8 buffer positions.")
+ (dolist (pos match)
+ (cl-check-type pos (or null integer-or-marker)))
+ (cl-destructuring-bind (all-beg all-end
+ ovr-beg ovr-end
+ txt-beg txt-end
+ und-beg und-end) match
+ (unless (and (integer-or-marker-p all-beg) (integer-or-marker-p all-end))
(signal 'args-out-of-range
- '("For a transition exactly the third match pair must be set."))))
- ((rst-Ado-is-simple ado)
- (unless (and (null (nth 2 match))
- (null (nth 3 match))
- (integer-or-marker-p (nth 4 match))
- (integer-or-marker-p (nth 5 match))
- (integer-or-marker-p (nth 6 match))
- (integer-or-marker-p (nth 7 match)))
- (signal 'args-out-of-range
- '("For a simple section adornment exactly the third and fourth
match pair must be set."))))
- (t ;; over-and-under
- (unless (and (integer-or-marker-p (nth 2 match))
- (integer-or-marker-p (nth 3 match))
- (integer-or-marker-p (nth 4 match))
- (integer-or-marker-p (nth 5 match))
- (or (null (nth 6 match)) (integer-or-marker-p (nth 6 match)))
- (or (null (nth 7 match)) (integer-or-marker-p (nth 7 match))))
- (signal 'args-out-of-range
- '("For a over-and-under section adornment all match pairs must be
set.")))))
+ '("First two elements of match data must be buffer positions.")))
+ (cond
+ ((null ado)
+ (unless (and (null ovr-beg) (null ovr-end)
+ (integer-or-marker-p txt-beg) (integer-or-marker-p txt-end)
+ (null und-beg) (null und-end))
+ (signal 'args-out-of-range
+ '("For a title candidate exactly the third match pair must be
set."))))
+ ((rst-Ado-is-transition ado)
+ (unless (and (null ovr-beg) (null ovr-end)
+ (integer-or-marker-p txt-beg) (integer-or-marker-p txt-end)
+ (null und-beg) (null und-end))
+ (signal 'args-out-of-range
+ '("For a transition exactly the third match pair must be
set."))))
+ ((rst-Ado-is-simple ado)
+ (unless (and (null ovr-beg) (null ovr-end)
+ (integer-or-marker-p txt-beg) (integer-or-marker-p txt-end)
+ (integer-or-marker-p und-beg) (integer-or-marker-p und-end))
+ (signal 'args-out-of-range
+ '("For a simple section adornment exactly the third and fourth
match pair must be set."))))
+ (t ; over-and-under
+ (unless (and (integer-or-marker-p ovr-beg) (integer-or-marker-p ovr-end)
+ (integer-or-marker-p txt-beg) (integer-or-marker-p txt-end)
+ (or (null und-beg) (integer-or-marker-p und-beg))
+ (or (null und-end) (integer-or-marker-p und-end)))
+ (signal 'args-out-of-range
+ '("For a over-and-under section adornment all match pairs must
be set."))))))
match)
(defun rst-Ttl--validate-indent (indent ado)
;; testcover: ok.
"Return valid INDENT for ADO or signal error."
(if (and ado (rst-Ado-is-transition ado))
- (unless (null indent)
- (signal 'args-out-of-range
- '("Indent for a transition must be nil.")))
- (unless (integerp indent)
- (signal 'wrong-type-argument
- (list 'integerp indent)))
- (unless (>= indent 0)
- (signal 'args-out-of-range
- '("Indent for a section header must be non-negative."))))
+ (cl-check-type indent null
+ "Indent for a transition must be nil.")
+ (cl-check-type indent (integer 0 *)
+ "Indent for a section header must be non-negative."))
indent)
-(defun rst-Ttl--validate-hdr (hdr ado indent)
- ;; testcover: ok.
- "Return valid HDR in relation to ADO and INDENT or signal error."
- (unless (rst-Hdr-p hdr)
- (signal 'wrong-type-argument
- (list 'rst-Hdr-p hdr)))
- (unless (rst-Ado-equal (rst-Hdr-ado hdr) ado)
- (signal 'args-out-of-range
- '("Basic adornment and adornment in header must match.")))
- (unless (equal (rst-Hdr-indent hdr) indent)
- (signal 'args-out-of-range
- '("Basic indent and indent in header must match.")))
- hdr)
-
(defun rst-Ttl--validate-text (text ado)
;; testcover: ok.
"Return valid TEXT for ADO or signal error."
(if (and ado (rst-Ado-is-transition ado))
- (unless (null text)
- (signal 'args-out-of-range
- '("Transitions may not have title text.")))
- (unless (stringp text)
- (signal 'wrong-type-argument
- (list 'stringp text))))
+ (cl-check-type text null
+ "Transitions may not have title text.")
+ (cl-check-type text string))
text)
-(defun rst-Ttl--validate-level (level)
+;; Public class methods
+
+(defun rst-Ttl-from-buffer (ado beg-ovr beg-txt beg-und txt)
;; testcover: ok.
- "Return valid LEVEL or signal error."
- (unless (integerp level)
- (signal 'wrong-type-argument
- (list 'integerp level)))
- (unless (>= level 0)
- (signal 'args-out-of-range
- '("Level must be non-negative.")))
- level)
+ "Return a `rst-Ttl' constructed from information in the current buffer.
+ADO is the adornment or nil for a title candidate. BEG-OVR and
+BEG-UND are the starting points of the overline or underline,
+respectively. They may be nil if the respective thing is missing.
+BEG-TXT is the beginning of the title line or the transition and
+must be given. The end of the line is used as the end point. TXT
+is the title text or nil. If TXT is given the indendation of the
+line containing BEG-TXT is used as indentation. Match group 0 is
+derived from the remaining information."
+ (cl-check-type beg-txt integer-or-marker)
+ (save-excursion
+ (let ((end-ovr (when beg-ovr
+ (goto-char beg-ovr)
+ (line-end-position)))
+ (end-txt (progn
+ (goto-char beg-txt)
+ (line-end-position)))
+ (end-und (when beg-und
+ (goto-char beg-und)
+ (line-end-position)))
+ (ind (when txt
+ (goto-char beg-txt)
+ (current-indentation))))
+ (rst-Ttl--new ado
+ (list
+ (or beg-ovr beg-txt) (or end-und end-txt)
+ beg-ovr end-ovr
+ beg-txt end-txt
+ beg-und end-und)
+ ind txt))))
;; Public methods
-(defun rst-Ttl-evaluate-hdr (self)
- ;; testcover: ok.
- "Check for `ado' and `indent' in SELF forming a valid `rst-Hdr'.
-Set and return it or nil if no valid `rst-Hdr' can be formed."
- (setf (rst-Ttl-hdr self)
- (condition-case nil
- (rst-Hdr-new (rst-Ttl-ado self) (rst-Ttl-indent self))
- (error nil))))
-
-(defun rst-Ttl-set-level (self level)
- ;; testcover: ok.
- "In SELF set and return LEVEL or nil if invalid."
- (setf (rst-Ttl-level self)
- (rst-Ttl--validate-level level)))
-
(defun rst-Ttl-get-title-beginning (self)
;; testcover: ok.
"Return position of beginning of title text of SELF.
This position should always be at the start of a line."
+ (cl-check-type self rst-Ttl)
(nth 4 (rst-Ttl-match self)))
(defun rst-Ttl-get-beginning (self)
;; testcover: ok.
"Return position of beginning of whole SELF."
+ (cl-check-type self rst-Ttl)
(nth 0 (rst-Ttl-match self)))
(defun rst-Ttl-get-end (self)
;; testcover: ok.
"Return position of end of whole SELF."
+ (cl-check-type self rst-Ttl)
(nth 1 (rst-Ttl-match self)))
+(defun rst-Ttl-is-section (self)
+ ;; testcover: ok.
+ "Return non-nil if SELF is a section header or candidate."
+ (cl-check-type self rst-Ttl)
+ (rst-Ttl-text self))
+
+(defun rst-Ttl-is-candidate (self)
+ ;; testcover: ok.
+ "Return non-nil if SELF is a candidate for a section header."
+ (cl-check-type self rst-Ttl)
+ (not (rst-Ttl-ado self)))
+
+(defun rst-Ttl-contains (self position)
+ "Return whether SELF contain POSITION.
+Return 0 if SELF contains POSITION, < 0 if SELF ends before
+POSITION and > 0 if SELF starts after position."
+ (cl-check-type self rst-Ttl)
+ (cl-check-type position integer-or-marker)
+ (cond
+ ((< (nth 1 (rst-Ttl-match self)) position)
+ -1)
+ ((> (nth 0 (rst-Ttl-match self)) position)
+ +1)
+ (0)))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Class rst-Stn
-(defstruct
+(cl-defstruct
(rst-Stn
- (:constructor nil) ;; Prevent creating unchecked values.
+ (:constructor nil) ; Prevent creating unchecked values.
;; Construct while all parameters must be valid.
(:constructor
rst-Stn-new
@@ -1102,45 +1102,33 @@ This type is immutable."
(level nil :read-only t)
;; The list of children of the node.
(children nil :read-only t))
+;; FIXME refactoring: Should have an attribute `buffer' for the buffer this
+;; title is found in. Or use `rst-Ttl-buffer'.
;; Private class methods
(defun rst-Stn--validate-ttl (ttl)
;; testcover: ok.
"Return valid TTL or signal error."
- (unless (or (null ttl) (rst-Ttl-p ttl))
- (signal 'wrong-type-argument
- (list 'null 'rst-Ttl-p ttl)))
+ (cl-check-type ttl (or null rst-Ttl))
ttl)
(defun rst-Stn--validate-level (level ttl)
;; testcover: ok.
"Return valid LEVEL for TTL or signal error."
- (unless (integerp level)
- (signal 'wrong-type-argument
- (list 'integerp level)))
- (when ttl
- (unless (or (not (rst-Ttl-level ttl))
- (equal (rst-Ttl-level ttl) level))
- (signal 'args-out-of-range
- '("A title must have correct level or none at all.")))
- (when (< level 0)
- ;; testcover: Never reached because a title may not have a negative level
- (signal 'args-out-of-range
- '("Top level node must not have a title."))))
+ (cl-check-type level integer)
+ (when (and ttl (< level 0))
+ ;; testcover: Never reached because a title may not have a negative level
+ (signal 'args-out-of-range
+ '("Top level node must not have a title.")))
level)
(defun rst-Stn--validate-children (children ttl)
;; testcover: ok.
"Return valid CHILDREN for TTL or signal error."
- (unless (listp children)
- (signal 'wrong-type-argument
- (list 'listp children)))
- (mapcar (lambda (child)
- (unless (rst-Stn-p child)
- (signal 'wrong-type-argument
- (list 'rst-Stn-p child))))
- children)
+ (cl-check-type children list)
+ (dolist (child children)
+ (cl-check-type child rst-Stn))
(unless (or ttl children)
(signal 'args-out-of-range
'("A missing node must have children.")))
@@ -1152,9 +1140,7 @@ This type is immutable."
;; testcover: ok.
"Return the beginning of the title of SELF.
Handles missing node properly."
- (unless (rst-Stn-p self)
- (signal 'wrong-type-argument
- (list 'rst-Stn-p self)))
+ (cl-check-type self rst-Stn)
(let ((ttl (rst-Stn-ttl self)))
(if ttl
(rst-Ttl-get-title-beginning ttl)
@@ -1164,9 +1150,7 @@ Handles missing node properly."
;; testcover: ok.
"Return title text of SELF or DEFAULT if SELF is a missing node.
For a missing node and no DEFAULT given return a standard title text."
- (unless (rst-Stn-p self)
- (signal 'wrong-type-argument
- (list 'rst-Stn-p self)))
+ (cl-check-type self rst-Stn)
(let ((ttl (rst-Stn-ttl self)))
(cond
(ttl
@@ -1177,9 +1161,7 @@ For a missing node and no DEFAULT given return a standard
title text."
(defun rst-Stn-is-top (self)
;; testcover: ok.
"Return non-nil if SELF is a top level node."
- (unless (rst-Stn-p self)
- (signal 'wrong-type-argument
- (list 'rst-Stn-p self)))
+ (cl-check-type self rst-Stn)
(< (rst-Stn-level self) 0))
@@ -1203,13 +1185,13 @@ as well but give an additional message."
(forwarder-function (intern forwarder-function-name)))
(unless (fboundp forwarder-function)
(defalias forwarder-function
- (lexical-let ((key key) (def def))
- (lambda ()
- (interactive)
- (call-interactively def)
- (message "[Deprecated use of key %s; use key %s instead]"
- (key-description (this-command-keys))
- (key-description key))))
+ (lambda ()
+ (interactive)
+ (call-interactively def)
+ (message "[Deprecated use of key %s; use key %s instead]"
+ (key-description (this-command-keys))
+ (key-description key)))
+ ;; FIXME: In Emacs-25 we could use (:documentation ...) instead.
(format "Deprecated binding for %s, use \\[%s] instead."
def def)))
(dolist (dep-key deprecated)
@@ -1220,40 +1202,40 @@ as well but give an additional message."
(let ((map (make-sparse-keymap)))
;; \C-c is the general keymap.
- (rst-define-key map [?\C-c ?\C-h] 'describe-prefix-bindings)
+ (rst-define-key map [?\C-c ?\C-h] #'describe-prefix-bindings)
;;
;; Section Adornments
;;
;; The adjustment function that adorns or rotates a section title.
- (rst-define-key map [?\C-c ?\C-=] 'rst-adjust [?\C-c ?\C-a t])
- (rst-define-key map [?\C-=] 'rst-adjust) ; Does not work on macOS and
- ; on consoles.
+ (rst-define-key map [?\C-c ?\C-=] #'rst-adjust [?\C-c ?\C-a t])
+ (rst-define-key map [?\C-=] #'rst-adjust) ; Does not work on macOS and
+ ; on consoles.
;; \C-c \C-a is the keymap for adornments.
- (rst-define-key map [?\C-c ?\C-a ?\C-h] 'describe-prefix-bindings)
+ (rst-define-key map [?\C-c ?\C-a ?\C-h] #'describe-prefix-bindings)
;; Another binding which works with all types of input.
- (rst-define-key map [?\C-c ?\C-a ?\C-a] 'rst-adjust)
+ (rst-define-key map [?\C-c ?\C-a ?\C-a] #'rst-adjust)
;; Display the hierarchy of adornments implied by the current document
;; contents.
- (rst-define-key map [?\C-c ?\C-a ?\C-d] 'rst-display-hdr-hierarchy)
+ (rst-define-key map [?\C-c ?\C-a ?\C-d] #'rst-display-hdr-hierarchy)
;; Homogenize the adornments in the document.
- (rst-define-key map [?\C-c ?\C-a ?\C-s] 'rst-straighten-sections
+ (rst-define-key map [?\C-c ?\C-a ?\C-s] #'rst-straighten-sections
[?\C-c ?\C-s])
;;
;; Section Movement and Selection
;;
;; Mark the subsection where the cursor is.
- (rst-define-key map [?\C-\M-h] 'rst-mark-section
+ (rst-define-key map [?\C-\M-h] #'rst-mark-section
;; Same as mark-defun sgml-mark-current-element.
[?\C-c ?\C-m])
;; Move backward/forward between section titles.
;; FIXME: Also bind similar to outline mode.
- (rst-define-key map [?\C-\M-a] 'rst-backward-section
+ (rst-define-key map [?\C-\M-a] #'rst-backward-section
;; Same as beginning-of-defun.
[?\C-c ?\C-n])
- (rst-define-key map [?\C-\M-e] 'rst-forward-section
+ (rst-define-key map [?\C-\M-e] #'rst-forward-section
;; Same as end-of-defun.
[?\C-c ?\C-p])
@@ -1261,69 +1243,69 @@ as well but give an additional message."
;; Operating on regions
;;
;; \C-c \C-r is the keymap for regions.
- (rst-define-key map [?\C-c ?\C-r ?\C-h] 'describe-prefix-bindings)
+ (rst-define-key map [?\C-c ?\C-r ?\C-h] #'describe-prefix-bindings)
;; Makes region a line-block.
- (rst-define-key map [?\C-c ?\C-r ?\C-l] 'rst-line-block-region
+ (rst-define-key map [?\C-c ?\C-r ?\C-l] #'rst-line-block-region
[?\C-c ?\C-d])
;; Shift region left or right according to tabs.
- (rst-define-key map [?\C-c ?\C-r tab] 'rst-shift-region
+ (rst-define-key map [?\C-c ?\C-r tab] #'rst-shift-region
[?\C-c ?\C-r t] [?\C-c ?\C-l t])
;;
;; Operating on lists
;;
;; \C-c \C-l is the keymap for lists.
- (rst-define-key map [?\C-c ?\C-l ?\C-h] 'describe-prefix-bindings)
+ (rst-define-key map [?\C-c ?\C-l ?\C-h] #'describe-prefix-bindings)
;; Makes paragraphs in region as a bullet list.
- (rst-define-key map [?\C-c ?\C-l ?\C-b] 'rst-bullet-list-region
+ (rst-define-key map [?\C-c ?\C-l ?\C-b] #'rst-bullet-list-region
[?\C-c ?\C-b])
;; Makes paragraphs in region as a enumeration.
- (rst-define-key map [?\C-c ?\C-l ?\C-e] 'rst-enumerate-region
+ (rst-define-key map [?\C-c ?\C-l ?\C-e] #'rst-enumerate-region
[?\C-c ?\C-e])
;; Converts bullets to an enumeration.
- (rst-define-key map [?\C-c ?\C-l ?\C-c] 'rst-convert-bullets-to-enumeration
+ (rst-define-key map [?\C-c ?\C-l ?\C-c]
#'rst-convert-bullets-to-enumeration
[?\C-c ?\C-v])
;; Make sure that all the bullets in the region are consistent.
- (rst-define-key map [?\C-c ?\C-l ?\C-s] 'rst-straighten-bullets-region
+ (rst-define-key map [?\C-c ?\C-l ?\C-s] #'rst-straighten-bullets-region
[?\C-c ?\C-w])
;; Insert a list item.
- (rst-define-key map [?\C-c ?\C-l ?\C-i] 'rst-insert-list)
+ (rst-define-key map [?\C-c ?\C-l ?\C-i] #'rst-insert-list)
;;
;; Table-of-Contents Features
;;
;; \C-c \C-t is the keymap for table of contents.
- (rst-define-key map [?\C-c ?\C-t ?\C-h] 'describe-prefix-bindings)
+ (rst-define-key map [?\C-c ?\C-t ?\C-h] #'describe-prefix-bindings)
;; Enter a TOC buffer to view and move to a specific section.
- (rst-define-key map [?\C-c ?\C-t ?\C-t] 'rst-toc)
+ (rst-define-key map [?\C-c ?\C-t ?\C-t] #'rst-toc)
;; Insert a TOC here.
- (rst-define-key map [?\C-c ?\C-t ?\C-i] 'rst-toc-insert
+ (rst-define-key map [?\C-c ?\C-t ?\C-i] #'rst-toc-insert
[?\C-c ?\C-i])
;; Update the document's TOC (without changing the cursor position).
- (rst-define-key map [?\C-c ?\C-t ?\C-u] 'rst-toc-update
+ (rst-define-key map [?\C-c ?\C-t ?\C-u] #'rst-toc-update
[?\C-c ?\C-u])
- ;; Go to the section under the cursor (cursor must be in TOC).
- (rst-define-key map [?\C-c ?\C-t ?\C-j] 'rst-goto-section
+ ;; Go to the section under the cursor (cursor must be in internal TOC).
+ (rst-define-key map [?\C-c ?\C-t ?\C-j] #'rst-toc-follow-link
[?\C-c ?\C-f])
;;
;; Converting Documents from Emacs
;;
;; \C-c \C-c is the keymap for compilation.
- (rst-define-key map [?\C-c ?\C-c ?\C-h] 'describe-prefix-bindings)
+ (rst-define-key map [?\C-c ?\C-c ?\C-h] #'describe-prefix-bindings)
;; Run one of two pre-configured toolset commands on the document.
- (rst-define-key map [?\C-c ?\C-c ?\C-c] 'rst-compile
+ (rst-define-key map [?\C-c ?\C-c ?\C-c] #'rst-compile
[?\C-c ?1])
- (rst-define-key map [?\C-c ?\C-c ?\C-a] 'rst-compile-alt-toolset
+ (rst-define-key map [?\C-c ?\C-c ?\C-a] #'rst-compile-alt-toolset
[?\C-c ?2])
;; Convert the active region to pseudo-xml using the docutils tools.
- (rst-define-key map [?\C-c ?\C-c ?\C-x] 'rst-compile-pseudo-region
+ (rst-define-key map [?\C-c ?\C-c ?\C-x] #'rst-compile-pseudo-region
[?\C-c ?3])
;; Convert the current document to PDF and launch a viewer on the results.
- (rst-define-key map [?\C-c ?\C-c ?\C-p] 'rst-compile-pdf-preview
+ (rst-define-key map [?\C-c ?\C-c ?\C-p] #'rst-compile-pdf-preview
[?\C-c ?4])
;; Convert the current document to S5 slides and view in a web browser.
- (rst-define-key map [?\C-c ?\C-c ?\C-s] 'rst-compile-slides-preview
+ (rst-define-key map [?\C-c ?\C-c ?\C-s] #'rst-compile-slides-preview
[?\C-c ?5])
map)
@@ -1333,7 +1315,8 @@ This inherits from Text mode.")
;; Abbrevs.
(define-abbrev-table 'rst-mode-abbrev-table
- (mapcar (lambda (x) (append x '(nil 0 system)))
+ (mapcar #'(lambda (x)
+ (append x '(nil 0 system)))
'(("contents" ".. contents::\n..\n ")
("con" ".. contents::\n..\n ")
("cont" "[...]")
@@ -1381,6 +1364,7 @@ The hook for `text-mode' is run before this one."
(require 'newcomment)
(defvar electric-pair-pairs)
+(defvar electric-indent-inhibit)
;; Use rst-mode for *.rst and *.rest files. Many ReStructured-Text files
;; use *.txt, but this is too generic to be set as a default.
@@ -1411,10 +1395,10 @@ highlighting.
(:seq hws-tag par-tag- bli-sfx))))
;; Indenting and filling.
- (setq-local indent-line-function 'rst-indent-line)
+ (setq-local indent-line-function #'rst-indent-line)
(setq-local adaptive-fill-mode t)
(setq-local adaptive-fill-regexp (rst-re 'hws-tag 'par-tag- "?" 'hws-tag))
- (setq-local adaptive-fill-function 'rst-adaptive-fill)
+ (setq-local adaptive-fill-function #'rst-adaptive-fill)
(setq-local fill-paragraph-handle-comment nil)
;; Comments.
@@ -1430,18 +1414,18 @@ highlighting.
;; Commenting in reStructuredText is very special so use our own set of
;; functions.
- (setq-local comment-line-break-function 'rst-comment-line-break)
- (setq-local comment-indent-function 'rst-comment-indent)
- (setq-local comment-insert-comment-function 'rst-comment-insert-comment)
- (setq-local comment-region-function 'rst-comment-region)
- (setq-local uncomment-region-function 'rst-uncomment-region)
+ (setq-local comment-line-break-function #'rst-comment-line-break)
+ (setq-local comment-indent-function #'rst-comment-indent)
+ (setq-local comment-insert-comment-function #'rst-comment-insert-comment)
+ (setq-local comment-region-function #'rst-comment-region)
+ (setq-local uncomment-region-function #'rst-uncomment-region)
(setq-local electric-pair-pairs '((?\" . ?\") (?\* . ?\*) (?\` . ?\`)))
;; Imenu and which function.
;; FIXME: Check documentation of `which-function' for alternative ways to
;; determine the current function name.
- (setq-local imenu-create-index-function 'rst-imenu-create-index)
+ (setq-local imenu-create-index-function #'rst-imenu-create-index)
;; Font lock.
(setq-local font-lock-defaults
@@ -1449,7 +1433,7 @@ highlighting.
t nil nil nil
(font-lock-multiline . t)
(font-lock-mark-block-function . mark-paragraph)))
- (add-hook 'font-lock-extend-region-functions 'rst-font-lock-extend-region t)
+ (add-hook 'font-lock-extend-region-functions #'rst-font-lock-extend-region t)
;; Text after a changed line may need new fontification.
(setq-local jit-lock-contextually t)
@@ -1562,9 +1546,9 @@ file."
:type `(repeat
(group :tag "Adornment specification"
(choice :tag "Adornment character"
- ,@(mapcar (lambda (char)
- (list 'const
- :tag (char-to-string char) char))
+ ,@(mapcar #'(lambda (char)
+ (list 'const
+ :tag (char-to-string char) char))
rst-adornment-chars))
(radio :tag "Adornment type"
(const :tag "Overline and underline" over-and-under)
@@ -1603,17 +1587,12 @@ search starts after this entry. Return nil if no new
preferred
;; Start searching after the level of the previous adornment.
(cdr (rst-Hdr-member-ado prev (rst-Hdr-preferred-adornments))))
(rst-Hdr-preferred-adornments))))
- (car
- (rst-member-if (lambda (cand)
- (not (rst-Hdr-member-ado cand seen)))
- candidates))))
-
-(defun rst-delete-entire-line ()
- "Delete the entire current line without using the `kill-ring'."
- (delete-region (line-beginning-position)
- (line-beginning-position 2)))
+ (cl-find-if #'(lambda (cand)
+ (not (rst-Hdr-member-ado cand seen)))
+ candidates)))
(defun rst-update-section (hdr)
+ ;; testcover: ok.
"Unconditionally update the style of the section header at point to HDR.
If there are existing overline and/or underline from the
existing adornment, they are removed before adding the
@@ -1621,163 +1600,149 @@ requested adornment."
(end-of-line)
(let ((indent (or (rst-Hdr-indent hdr) 0))
(marker (point-marker))
- len)
+ new)
;; Fixup whitespace at the beginning and end of the line.
- (beginning-of-line)
+ (1value
+ (rst-forward-line-strict 0))
(delete-horizontal-space)
(insert (make-string indent ? ))
-
(end-of-line)
(delete-horizontal-space)
-
- ;; Set the current column, we're at the end of the title line.
- (setq len (+ (current-column) indent))
+ (setq new (make-string (+ (current-column) indent) (rst-Hdr-get-char hdr)))
;; Remove previous line if it is an adornment.
- (save-excursion
- (forward-line -1) ;; FIXME testcover: Doesn't work when in first line of
- ;; buffer.
- (if (and (looking-at (rst-re 'ado-beg-2-1))
+ ;; FIXME refactoring: Check whether this deletes `hdr' which *has* all the
+ ;; data necessary.
+ (when (and (rst-forward-line-looking-at -1 'ado-beg-2-1)
;; Avoid removing the underline of a title right above us.
- (save-excursion (forward-line -1)
- (not (looking-at (rst-re 'ttl-beg-1)))))
- (rst-delete-entire-line)))
+ (not (rst-forward-line-looking-at -2 'ttl-beg-1)))
+ (rst-delete-entire-line -1))
;; Remove following line if it is an adornment.
- (save-excursion
- (forward-line +1) ;; FIXME testcover: Doesn't work when in last line
- ;; of buffer.
- (if (looking-at (rst-re 'ado-beg-2-1))
- (rst-delete-entire-line))
- ;; Add a newline if we're at the end of the buffer unless it is the final
- ;; empty line, for the subsequent inserting of the underline.
- (if (and (= (point) (buffer-end 1)) (not (bolp)))
- (newline 1)))
-
- ;; Insert overline.
- (when (rst-Hdr-is-over-and-under hdr)
- (save-excursion
- (beginning-of-line)
- (open-line 1)
- (insert (make-string len (rst-Hdr-get-char hdr)))))
+ (when (rst-forward-line-looking-at +1 'ado-beg-2-1)
+ (rst-delete-entire-line +1))
;; Insert underline.
- (1value ;; Line has been inserted above.
- (forward-line +1))
+ (unless (rst-forward-line-strict +1)
+ ;; Normalize buffer by adding final newline.
+ (newline 1))
(open-line 1)
- (insert (make-string len (rst-Hdr-get-char hdr)))
+ (insert new)
+
+ ;; Insert overline.
+ (when (rst-Hdr-is-over-and-under hdr)
+ (1value ; Underline inserted above.
+ (rst-forward-line-strict -1))
+ (open-line 1)
+ (insert new))
- (1value ;; Line has been inserted above.
- (forward-line +1))
(goto-char marker)))
-(defun rst-classify-adornment (adornment end)
+(defun rst-classify-adornment (adornment end &optional accept-over-only)
+ ;; testcover: ok.
"Classify adornment string for section titles and transitions.
ADORNMENT is the complete adornment string as found in the buffer
with optional trailing whitespace. END is the point after the
last character of ADORNMENT. Return a `rst-Ttl' or nil if no
-syntactically valid adornment is found."
+syntactically valid adornment is found. If ACCEPT-OVER-ONLY an
+overline with a missing underline is accepted as valid and
+returned."
(save-excursion
(save-match-data
(when (string-match (rst-re 'ado-beg-2-1) adornment)
(goto-char end)
(let* ((ado-ch (string-to-char (match-string 2 adornment)))
- (ado-re (rst-re ado-ch 'adorep3-hlp))
- (end-pnt (point))
+ (ado-re (rst-re ado-ch 'adorep3-hlp)) ; RE matching the
+ ; adornment.
(beg-pnt (progn
- (1value ;; No lines may be left to move.
- (forward-line 0))
+ (1value
+ (rst-forward-line-strict 0))
(point)))
(nxt-emp ; Next line nonexistent or empty
- (save-excursion
- (or (not (zerop (forward-line 1)))
- ;; FIXME testcover: Add test classifying at the end of
- ;; buffer.
- (looking-at (rst-re 'lin-end)))))
+ (not (rst-forward-line-looking-at +1 'lin-end #'not)))
(prv-emp ; Previous line nonexistent or empty
- (save-excursion
- (or (not (zerop (forward-line -1)))
- (looking-at (rst-re 'lin-end)))))
+ (not (rst-forward-line-looking-at -1 'lin-end #'not)))
txt-blw
(ttl-blw ; Title found below starting here.
- (save-excursion
- (and
- (zerop (forward-line 1)) ;; FIXME testcover: Add test
- ;; classifying at the end of
- ;; buffer.
- (looking-at (rst-re 'ttl-beg-1))
- (setq txt-blw (match-string-no-properties 1))
- (point))))
+ (rst-forward-line-looking-at
+ +1 'ttl-beg-1
+ #'(lambda (mtcd)
+ (when mtcd
+ (setq txt-blw (match-string-no-properties 1))
+ (point)))))
txt-abv
(ttl-abv ; Title found above starting here.
- (save-excursion
- (and
- (zerop (forward-line -1))
- (looking-at (rst-re 'ttl-beg-1))
- (setq txt-abv (match-string-no-properties 1))
- (point))))
+ (rst-forward-line-looking-at
+ -1 'ttl-beg-1
+ #'(lambda (mtcd)
+ (when mtcd
+ (setq txt-abv (match-string-no-properties 1))
+ (point)))))
(und-fnd ; Matching underline found starting here.
- (save-excursion
- (and ttl-blw
- (zerop (forward-line 2)) ;; FIXME testcover: Add test
- ;; classifying at the end of
- ;; buffer.
- (looking-at (rst-re ado-re 'lin-end))
- (point))))
+ (and ttl-blw
+ (rst-forward-line-looking-at
+ +2 (list ado-re 'lin-end)
+ #'(lambda (mtcd)
+ (when mtcd
+ (point))))))
(ovr-fnd ; Matching overline found starting here.
- (save-excursion
- (and ttl-abv
- (zerop (forward-line -2))
- (looking-at (rst-re ado-re 'lin-end))
- (point))))
- ado ind txt beg-ovr end-ovr beg-txt end-txt beg-und end-und)
+ (and ttl-abv
+ (rst-forward-line-looking-at
+ -2 (list ado-re 'lin-end)
+ #'(lambda (mtcd)
+ (when mtcd
+ (point))))))
+ (und-wng ; Wrong underline found starting here.
+ (and ttl-blw
+ (not und-fnd)
+ (rst-forward-line-looking-at
+ +2 'ado-beg-2-1
+ #'(lambda (mtcd)
+ (when mtcd
+ (point))))))
+ (ovr-wng ; Wrong overline found starting here.
+ (and ttl-abv (not ovr-fnd)
+ (rst-forward-line-looking-at
+ -2 'ado-beg-2-1
+ #'(lambda (mtcd)
+ (when (and
+ mtcd
+ ;; An adornment above may be a legal
+ ;; adornment for the line above - consider it
+ ;; a wrong overline only when it is equally
+ ;; long.
+ (equal
+ (length (match-string-no-properties 1))
+ (length adornment)))
+ (point)))))))
(cond
((and nxt-emp prv-emp)
;; A transition.
- (setq ado (rst-Ado-new-transition)
- beg-txt beg-pnt
- end-txt end-pnt))
- ((or und-fnd ovr-fnd)
+ (rst-Ttl-from-buffer (rst-Ado-new-transition)
+ nil beg-pnt nil nil))
+ (ovr-fnd ; Prefer overline match over underline match.
;; An overline with an underline.
- (setq ado (rst-Ado-new-over-and-under ado-ch))
- (let (;; Prefer overline match over underline match.
- (und-pnt (if ovr-fnd beg-pnt und-fnd))
- (ovr-pnt (if ovr-fnd ovr-fnd beg-pnt))
- (txt-pnt (if ovr-fnd ttl-abv ttl-blw)))
- (goto-char ovr-pnt)
- (setq beg-ovr (point)
- end-ovr (line-end-position))
- (goto-char txt-pnt)
- (setq beg-txt (point)
- end-txt (line-end-position)
- ind (current-indentation)
- txt (if ovr-fnd txt-abv txt-blw))
- (goto-char und-pnt)
- (setq beg-und (point)
- end-und (line-end-position))))
- (ttl-abv
+ (rst-Ttl-from-buffer (rst-Ado-new-over-and-under ado-ch)
+ ovr-fnd ttl-abv beg-pnt txt-abv))
+ (und-fnd
+ ;; An overline with an underline.
+ (rst-Ttl-from-buffer (rst-Ado-new-over-and-under ado-ch)
+ beg-pnt ttl-blw und-fnd txt-blw))
+ ((and ttl-abv (not ovr-wng))
;; An underline.
- (setq ado (rst-Ado-new-simple ado-ch)
- beg-und beg-pnt
- end-und end-pnt)
- (goto-char ttl-abv)
- (setq beg-txt (point)
- end-txt (line-end-position)
- ind (current-indentation)
- txt txt-abv))
+ (rst-Ttl-from-buffer (rst-Ado-new-simple ado-ch)
+ nil ttl-abv beg-pnt txt-abv))
+ ((and accept-over-only ttl-blw (not und-wng))
+ ;; An overline with a missing underline.
+ (rst-Ttl-from-buffer (rst-Ado-new-over-and-under ado-ch)
+ beg-pnt ttl-blw nil txt-blw))
(t
;; Invalid adornment.
- (setq ado nil)))
- (if ado
- (rst-Ttl-new ado
- (list
- (or beg-ovr beg-txt)
- (or end-und end-txt)
- beg-ovr end-ovr beg-txt end-txt beg-und end-und)
- ind txt)))))))
+ nil)))))))
(defun rst-ttl-at-point ()
+ ;; testcover: ok.
"Find a section title line around point and return its characteristics.
If the point is on an adornment line find the respective title
line. 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
point is on a suitable title line use it. Return a `rst-Ttl' for
a section header or nil if no title line is found."
(save-excursion
- (1value ;; No lines may be left to move.
- (forward-line 0))
- (let ((orig-pnt (point))
- (orig-end (line-end-position)))
- (cond
- ((looking-at (rst-re 'ado-beg-2-1))
- ;; Adornment found - consider it.
- (let ((char (string-to-char (match-string-no-properties 2)))
- (r (rst-classify-adornment (match-string-no-properties 0)
- (match-end 0))))
- (cond
- ((not r)
- ;; Invalid adornment - check whether this is an overline with
- ;; missing underline.
- (if (and
- (zerop (forward-line 1))
- (looking-at (rst-re 'ttl-beg-1)))
- (rst-Ttl-new (rst-Ado-new-over-and-under char)
- (list orig-pnt (line-end-position)
- orig-pnt orig-end
- (point) (line-end-position)
- nil nil)
- (current-indentation)
- (match-string-no-properties 1))))
- ((rst-Ado-is-transition (rst-Ttl-ado r))
- nil)
- ;; Return any other classification as is.
- (r))))
- ((looking-at (rst-re 'lin-end))
- ;; Empty line found - check surrounding lines for a title.
- (or
- (save-excursion
- (if (and (zerop (forward-line -1))
- (looking-at (rst-re 'ttl-beg-1)))
- (rst-Ttl-new nil
- (list (point) (line-end-position)
- nil nil
- (point) (line-end-position)
- nil nil)
- (current-indentation)
- (match-string-no-properties 1))))
- (save-excursion
- (if (and (zerop (forward-line 1))
- (looking-at (rst-re 'ttl-beg-1)))
- (rst-Ttl-new nil
- (list (point) (line-end-position)
- nil nil
- (point) (line-end-position)
- nil nil)
- (current-indentation)
- (match-string-no-properties 1))))))
- ((looking-at (rst-re 'ttl-beg-1))
- ;; Title line found - check for a following underline.
- (let ((txt (match-string-no-properties 1)))
- (or (rst-classify-adornment
- (buffer-substring-no-properties
- (line-beginning-position 2) (line-end-position 2))
- (line-end-position 2))
- ;; No valid adornment found.
- (rst-Ttl-new nil
- (list (point) (line-end-position)
- nil nil
- (point) (line-end-position)
- nil nil)
- (current-indentation)
- txt))))))))
+ (save-match-data
+ (1value
+ (rst-forward-line-strict 0))
+ (let* (cnd-beg ; Beginning of a title candidate.
+ cnd-txt ; Text of a title candidate.
+ (cnd-fun #'(lambda (mtcd) ; Function setting title candidate data.
+ (when mtcd
+ (setq cnd-beg (match-beginning 0))
+ (setq cnd-txt (match-string-no-properties 1))
+ t)))
+ ttl)
+ (cond
+ ((looking-at (rst-re 'ado-beg-2-1))
+ ;; Adornment found - consider it.
+ (setq ttl (rst-classify-adornment (match-string-no-properties 0)
+ (match-end 0) t)))
+ ((looking-at (rst-re 'lin-end))
+ ;; Empty line found - check surrounding lines for a title.
+ (or
+ (rst-forward-line-looking-at -1 'ttl-beg-1 cnd-fun)
+ (rst-forward-line-looking-at +1 'ttl-beg-1 cnd-fun)))
+ ((looking-at (rst-re 'ttl-beg-1))
+ ;; Title line found - check for a following underline.
+ (setq ttl (rst-forward-line-looking-at
+ 1 'ado-beg-2-1
+ #'(lambda (mtcd)
+ (when mtcd
+ (rst-classify-adornment
+ (match-string-no-properties 0) (match-end 0))))))
+ ;; Title candidate found if no valid adornment found.
+ (funcall cnd-fun (not ttl))))
+ (cond
+ ((and ttl (rst-Ttl-is-section ttl))
+ ttl)
+ (cnd-beg
+ (rst-Ttl-from-buffer nil nil cnd-beg nil cnd-txt)))))))
;; The following function and variables are used to maintain information about
;; current section adornment in a buffer local cache. Thus they can be used for
;; font-locking and manipulation commands.
-(defvar rst-all-ttls-cache nil
+(defvar-local rst-all-ttls-cache nil
"All section adornments in the buffer as found by `rst-all-ttls'.
Set to t when no section adornments were found.")
-(make-variable-buffer-local 'rst-all-ttls-cache)
;; FIXME: If this variable is set to a different value font-locking of section
;; headers is wrong.
-(defvar rst-hdr-hierarchy-cache nil
+(defvar-local rst-hdr-hierarchy-cache nil
"Section hierarchy in the buffer as determined by `rst-hdr-hierarchy'.
Set to t when no section adornments were found.
Value depends on `rst-all-ttls-cache'.")
-(make-variable-buffer-local 'rst-hdr-hierarchy-cache)
(rst-testcover-add-1value 'rst-reset-section-caches)
(defun rst-reset-section-caches ()
@@ -1876,94 +1809,92 @@ Should be called by interactive functions which deal
with sections."
(setq rst-all-ttls-cache nil
rst-hdr-hierarchy-cache nil))
+(defun rst-all-ttls-compute ()
+ ;; testcover: ok.
+ "Return a list of `rst-Ttl' for current buffer with ascending line number."
+ (save-excursion
+ (save-match-data
+ (let (ttls)
+ (goto-char (point-min))
+ ;; Iterate over all the section titles/adornments in the file.
+ (while (re-search-forward (rst-re 'ado-beg-2-1) nil t)
+ (let ((ttl (rst-classify-adornment
+ (match-string-no-properties 0) (point))))
+ (when (and ttl (rst-Ttl-is-section ttl))
+ (when (rst-Ttl-hdr ttl)
+ (push ttl ttls))
+ (goto-char (rst-Ttl-get-end ttl)))))
+ (nreverse ttls)))))
+
(defun rst-all-ttls ()
"Return all the section adornments in the current buffer.
Return a list of `rst-Ttl' with ascending line number.
Uses and sets `rst-all-ttls-cache'."
(unless rst-all-ttls-cache
- (let (positions)
- ;; Iterate over all the section titles/adornments in the file.
- (save-excursion
- (save-match-data
- (goto-char (point-min))
- (while (re-search-forward (rst-re 'ado-beg-2-1) nil t)
- (let ((ttl (rst-classify-adornment
- (match-string-no-properties 0) (point))))
- (when (and ttl (rst-Ado-is-section (rst-Ttl-ado ttl)))
- (when (rst-Ttl-evaluate-hdr ttl)
- (push ttl positions))
- (goto-char (rst-Ttl-get-end ttl)))))
- (setq positions (nreverse positions))
- (setq rst-all-ttls-cache (or positions t))))))
+ (setq rst-all-ttls-cache (or (rst-all-ttls-compute) t)))
(if (eq rst-all-ttls-cache t)
nil
- (mapcar 'rst-Ttl-copy rst-all-ttls-cache)))
+ (copy-sequence rst-all-ttls-cache)))
(defun rst-infer-hdr-hierarchy (hdrs)
+ ;; testcover: ok.
"Build a hierarchy from HDRS.
HDRS reflects the order in which the headers appear in the
buffer. Return a `rst-Hdr' list representing the hierarchy of
headers in the buffer. Indentation is unified."
- (let (ado2indents)
+ (let (ado2indents) ; Asscociates `rst-Ado' with the set of indents seen for
+ ; it.
(dolist (hdr hdrs)
(let* ((ado (rst-Hdr-ado hdr))
(indent (rst-Hdr-indent hdr))
(found (assoc ado ado2indents)))
(if found
- (unless (member indent (cdr found))
- ;; Append newly found indent.
- (setcdr found (append (cdr found) (list indent))))
+ (setcdr found (cl-adjoin indent (cdr found)))
(push (list ado indent) ado2indents))))
- (mapcar (lambda (ado_indents)
- (let ((ado (car ado_indents))
- (indents (cdr ado_indents)))
- (rst-Hdr-new
- ado
- (if (> (length indents) 1)
- ;; Indentations used inconsistently - use default.
- rst-default-indent
- ;; Only one indentation used - use this.
- (car indents)))))
+ (mapcar (cl-function
+ (lambda ((ado consistent &rest inconsistent))
+ (rst-Hdr-new ado (if inconsistent
+ rst-default-indent
+ consistent))))
(nreverse ado2indents))))
-(defun rst-hdr-hierarchy (&optional ignore-current)
+(defun rst-hdr-hierarchy (&optional ignore-position)
+ ;; testcover: ok.
"Return the hierarchy of section titles in the file as a `rst-Hdr' list.
Each returned element may be used directly to create a section
-adornment on that level. If IGNORE-CURRENT a title found on the
-current line is not taken into account when building the
+adornment on that level. If IGNORE-POSITION a title containing
+this position is not taken into account when building the
hierarchy unless it appears again elsewhere. This catches cases
where the current title is edited and may not be final regarding
its level.
-Uses and sets `rst-hdr-hierarchy-cache' unless IGNORE-CURRENT is
+Uses and sets `rst-hdr-hierarchy-cache' unless IGNORE-POSITION is
given."
(let* ((all-ttls (rst-all-ttls))
- (ignore-position (if ignore-current
- (line-beginning-position)))
(ignore-ttl
(if ignore-position
- (car (member-if
- (lambda (ttl)
- (equal ignore-position (rst-Ttl-get-title-beginning ttl)))
- all-ttls))))
+ (cl-find-if
+ #'(lambda (ttl)
+ (equal (rst-Ttl-contains ttl ignore-position) 0))
+ all-ttls)))
(really-ignore
(if ignore-ttl
- (<= (count-if
- (lambda (ttl)
- (rst-Ado-equal (rst-Ttl-ado ignore-ttl) (rst-Ttl-ado ttl)))
+ (<= (cl-count-if
+ #'(lambda (ttl)
+ (rst-Ado-equal (rst-Ttl-ado ignore-ttl)
+ (rst-Ttl-ado ttl)))
all-ttls)
1)))
(real-ttls (delq (if really-ignore ignore-ttl) all-ttls)))
- (mapcar ;; Protect cache.
- 'rst-Hdr-copy
- (if (and (not ignore-current) rst-hdr-hierarchy-cache)
+ (copy-sequence ; Protect cache.
+ (if (and (not ignore-position) rst-hdr-hierarchy-cache)
(if (eq rst-hdr-hierarchy-cache t)
nil
rst-hdr-hierarchy-cache)
- (let ((r (rst-infer-hdr-hierarchy (mapcar 'rst-Ttl-hdr real-ttls))))
+ (let ((r (rst-infer-hdr-hierarchy (mapcar #'rst-Ttl-hdr real-ttls))))
(setq rst-hdr-hierarchy-cache
- (if ignore-current
+ (if ignore-position
;; Clear cache reflecting that a possible update is not
;; reflected.
nil
@@ -1971,48 +1902,43 @@ given."
r)))))
(defun rst-all-ttls-with-level ()
+ ;; testcover: ok.
"Return the section adornments with levels set according to hierarchy.
-Return a list of `rst-Ttl' with ascending line number."
- (let ((hier (rst-Hdr-ado-map (rst-hdr-hierarchy))))
- (mapcar
- (lambda (ttl)
- (rst-Ttl-set-level ttl (rst-Ado-position (rst-Ttl-ado ttl) hier))
- ttl)
- (rst-all-ttls))))
+Return a list of (`rst-Ttl' . LEVEL) with ascending line number."
+ (let ((hier (rst-Hdr-ado-map (rst-hdr-hierarchy))))
+ (mapcar
+ #'(lambda (ttl)
+ (cons ttl (rst-Ado-position (rst-Ttl-ado ttl) hier)))
+ (rst-all-ttls))))
(defun rst-get-previous-hdr ()
"Return the `rst-Hdr' before point or nil if none."
- (let ((ttls (rst-all-ttls))
- (curpos (line-beginning-position))
- prev)
-
- ;; Search for the adornments around the current line.
- (while (and ttls (< (rst-Ttl-get-title-beginning (car ttls)) curpos))
- (setq prev (car ttls)
- ttls (cdr ttls)))
+ (let ((prev (cl-find-if #'(lambda (ttl)
+ (< (rst-Ttl-contains ttl (point)) 0))
+ (rst-all-ttls)
+ :from-end t)))
(and prev (rst-Ttl-hdr prev))))
(defun rst-adornment-complete-p (ado indent)
- "Return true if the adornment ADO around point is complete using INDENT.
+ ;; testcover: ok.
+ "Return t if the adornment ADO around point is complete using INDENT.
The adornment is complete if it is a completely correct
reStructuredText adornment for the title line at point. This
includes indentation and correct length of adornment lines."
;; Note: we assume that the detection of the overline as being the underline
;; of a preceding title has already been detected, and has been eliminated
;; from the adornment that is given to us.
- (let ((exps (rst-re "^" (rst-Ado-char ado)
- (format "\\{%d\\}"
- (+ (save-excursion
- ;; Determine last column of title.
- (end-of-line)
- (current-column))
- indent)) "$")))
- (and
- (save-excursion (forward-line +1)
- (looking-at exps))
- (or (rst-Ado-is-simple ado)
- (save-excursion (forward-line -1)
- (looking-at exps))))))
+ (let ((exps (list "^" (rst-Ado-char ado)
+ (format "\\{%d\\}"
+ (+ (save-excursion
+ ;; Determine last column of title.
+ (end-of-line)
+ (current-column))
+ indent)) "$")))
+ (and (rst-forward-line-looking-at +1 exps)
+ (or (rst-Ado-is-simple ado)
+ (rst-forward-line-looking-at -1 exps))
+ t))) ; Normalize return value.
(defun rst-next-hdr (hdr hier prev down)
;; testcover: ok.
@@ -2042,6 +1968,7 @@ HIER is nil."
;; FIXME: A line "``/`` full" is not accepted as a section title.
(defun rst-adjust (pfxarg)
+ ;; testcover: ok.
"Auto-adjust the adornment around point.
Adjust/rotate the section adornment for the section title around
point or promote/demote the adornments inside the region,
@@ -2056,7 +1983,7 @@ to deal with all the possible cases gracefully and to do
\"the
right thing\" in all cases.
See the documentations of `rst-adjust-section' and
-`rst-promote-region' for full details.
+`rst-adjust-region' for full details.
The method can take either (but not both) of
@@ -2067,28 +1994,18 @@ b. a negative numerical argument, which generally
inverts the
direction of search in the file or hierarchy. Invoke with C--
prefix for example."
(interactive "P")
-
- (let* (;; Save our original position on the current line.
- (origpt (point-marker))
-
+ (let* ((origpt (point-marker))
(reverse-direction (and pfxarg (< (prefix-numeric-value pfxarg) 0)))
(toggle-style (and pfxarg (not reverse-direction))))
-
(if (use-region-p)
- ;; Adjust adornments within region.
- (rst-promote-region (and pfxarg t))
- ;; Adjust adornment around point.
+ (rst-adjust-region (and pfxarg t))
(let ((msg (rst-adjust-section toggle-style reverse-direction)))
(when msg
- (apply 'message msg))))
-
- ;; Run the hooks to run after adjusting.
+ (apply #'message msg))))
(run-hooks 'rst-adjust-hook)
-
(rst-reset-section-caches)
-
- ;; Make sure to reset the cursor position properly after we're done.
- (goto-char origpt)))
+ (set-marker
+ (goto-char origpt) nil)))
(defcustom rst-adjust-hook nil
"Hooks to be run after running `rst-adjust'."
@@ -2116,8 +2033,77 @@ Argument PFXARG has the same meaning as for
`rst-adjust'."
(toggle-style (and pfxarg (not reverse-direction))))
(rst-adjust-section toggle-style reverse-direction)))
+(defun rst-adjust-new-hdr (toggle-style reverse ttl)
+ ;; testcover: ok.
+ "Return a new `rst-Hdr' for `rst-adjust-section' related to TTL.
+TOGGLE-STYLE and REVERSE are from
+`rst-adjust-section'. TOGGLE-STYLE may be consumed and thus is
+returned.
+
+Return a list (HDR TOGGLE-STYLE MSG...). HDR is the result or
+nil. TOGGLE-STYLE is the new TOGGLE-STYLE to use in the
+caller. MSG is a list which is non-empty in case HDR is nil
+giving an argument list for `message'."
+ (save-excursion
+ (goto-char (rst-Ttl-get-title-beginning ttl))
+ (let ((indent (rst-Ttl-indent ttl))
+ (ado (rst-Ttl-ado ttl))
+ (prev (rst-get-previous-hdr))
+ hdr-msg)
+ (setq
+ hdr-msg
+ (cond
+ ((rst-Ttl-is-candidate ttl)
+ ;; Case 1: No adornment at all.
+ (let ((hier (rst-hdr-hierarchy)))
+ (if prev
+ ;; Previous header exists - use it.
+ (cond
+ ;; Customization and parameters require that the previous level
+ ;; is used - use it as is.
+ ((or (and rst-new-adornment-down reverse)
+ (and (not rst-new-adornment-down) (not reverse)))
+ prev)
+ ;; Advance one level down.
+ ((rst-next-hdr prev hier prev t))
+ ("Neither hierarchy nor preferences can suggest a deeper
header"))
+ ;; First header in the buffer - use the first adornment from
+ ;; preferences or hierarchy.
+ (let ((p (car (rst-Hdr-preferred-adornments)))
+ (h (car hier)))
+ (cond
+ ((if reverse
+ ;; Prefer hierarchy for downwards
+ (or h p)
+ ;; Prefer preferences for upwards
+ (or p h)))
+ ("No preferences to suggest a top level from"))))))
+ ((not (rst-adornment-complete-p ado indent))
+ ;; Case 2: Incomplete adornment.
+ ;; Use lax since indentation might not match suggestion.
+ (rst-Hdr-new-lax ado indent))
+ ;; Case 3: Complete adornment exists from here on.
+ (toggle-style
+ ;; Simply switch the style of the current adornment.
+ (setq toggle-style nil) ; Remember toggling has been done.
+ (rst-Hdr-new-invert ado rst-default-indent))
+ (t
+ ;; Rotate, ignoring a sole adornment around the current line.
+ (let ((hier (rst-hdr-hierarchy (point))))
+ (cond
+ ;; Next header can be determined from hierarchy or preferences.
+ ((rst-next-hdr
+ ;; Use lax since indentation might not match suggestion.
+ (rst-Hdr-new-lax ado indent) hier prev reverse))
+ ;; No next header found.
+ ("No preferences or hierarchy to suggest another level from"))))))
+ (if (stringp hdr-msg)
+ (list nil toggle-style hdr-msg)
+ (list hdr-msg toggle-style)))))
+
(defun rst-adjust-section (toggle-style reverse)
-"Adjust/rotate the section adornment for the section title around point.
+ ;; testcover: ok.
+ "Adjust/rotate the section adornment for the section title around point.
The action this function takes depends on context around the
point, and it is meant to be invoked possibly more than once to
rotate among the various possibilities. Basically, this function
@@ -2191,135 +2177,71 @@ around the cursor. Then the following cases are
distinguished.
However, if TOGGLE-STYLE, we do not rotate the adornment, but instead simply
toggle the style of the current adornment."
(rst-reset-section-caches)
- (let ((ttl (rst-ttl-at-point))
- (orig-pnt (point))
- msg)
+ (let ((ttl (rst-ttl-at-point)))
(if (not ttl)
- (setq msg '("No section header or candidate at point"))
- (goto-char (rst-Ttl-get-title-beginning ttl))
- (let ((moved (- (line-number-at-pos) (line-number-at-pos orig-pnt)))
- (found (rst-Ttl-ado ttl))
- (indent (rst-Ttl-indent ttl))
- (prev (rst-get-previous-hdr))
- new)
- (when (and found (not (rst-Ado-p found)))
- ;; Normalize found adornment - overline with no underline counts as
- ;; overline.
- (setq found (rst-Ado-new-over-and-under found)))
- (setq new
- (cond
- ((not found)
- ;; Case 1: No adornment at all.
- (let ((hier (rst-hdr-hierarchy)))
- (if prev
- ;; Previous header exists - use it.
- (cond
- ;; Customization and parameters require that the
- ;; previous level is used - use it as is.
- ((or (and rst-new-adornment-down reverse)
- (and (not rst-new-adornment-down) (not reverse)))
- prev)
- ;; Advance one level down.
- ((rst-next-hdr prev hier prev t))
- (t
- (setq msg '("Neither hierarchy nor preferences can
suggest a deeper header"))
- nil))
- ;; First header in the buffer - use the first adornment
- ;; from preferences or hierarchy.
- (let ((p (car (rst-Hdr-preferred-adornments)))
- (h (car hier)))
- (cond
- ((if reverse
- ;; Prefer hierarchy for downwards
- (or h p)
- ;; Prefer preferences for upwards
- (or p h)))
- (t
- (setq msg '("No preferences to suggest a top level
from"))
- nil))))))
- ((not (rst-adornment-complete-p found indent))
- ;; Case 2: Incomplete adornment.
- ;; Use lax since indentation might not match suggestion.
- (rst-Hdr-new-lax found indent))
- ;; Case 3: Complete adornment exists from here on.
- (toggle-style
- ;; Simply switch the style of the current adornment.
- (setq toggle-style nil) ;; Remember toggling has been done.
- (rst-Hdr-new-invert found rst-default-indent))
- (t
- ;; Rotate, ignoring a sole adornment around the current line.
- (let ((hier (rst-hdr-hierarchy t)))
- (cond
- ;; Next header can be determined from hierarchy or
- ;; preferences.
- ((rst-next-hdr
- ;; Use lax since indentation might not match suggestion.
- (rst-Hdr-new-lax found indent) hier prev reverse))
- ;; No next header found.
- (t
- (setq msg '("No preferences or hierarchy to suggest another
level from"))
- nil))))))
- (if (not new)
- (goto-char orig-pnt)
+ '("No section header or candidate at point")
+ (cl-destructuring-bind
+ (hdr toggle-style &rest msg
+ &aux
+ (indent (rst-Ttl-indent ttl))
+ (moved (- (line-number-at-pos (rst-Ttl-get-title-beginning ttl))
+ (line-number-at-pos))))
+ (rst-adjust-new-hdr toggle-style reverse ttl)
+ (if msg
+ msg
(when toggle-style
- (setq new (rst-Hdr-new-invert (rst-Hdr-ado new) indent)))
+ (setq hdr (rst-Hdr-new-invert (rst-Hdr-ado hdr) indent)))
;; Override indent with present indent if there is some.
(when (> indent 0)
;; Use lax since existing indent may not be valid for new style.
- (setq new (rst-Hdr-new-lax (rst-Hdr-ado new) indent)))
- (rst-update-section new)
- ;; Correct the position of the cursor to more accurately reflect where
- ;; it was located when the function was invoked.
+ (setq hdr (rst-Hdr-new-lax (rst-Hdr-ado hdr) indent)))
+ (goto-char (rst-Ttl-get-title-beginning ttl))
+ (rst-update-section hdr)
+ ;; Correct the position of the cursor to more accurately reflect
+ ;; where it was located when the function was invoked.
(unless (zerop moved)
- (forward-line (- moved))
- (end-of-line)))))
- msg))
+ (1value ; No lines may be left to move.
+ (rst-forward-line-strict (- moved)))
+ (end-of-line))
+ nil)))))
;; Maintain an alias for compatibility.
(defalias 'rst-adjust-section-title 'rst-adjust)
-(defun rst-promote-region (demote)
+(defun rst-adjust-region (demote)
+ ;; testcover: ok.
"Promote the section titles within the region.
With argument DEMOTE or a prefix argument, demote the section
titles instead. The algorithm used at the boundaries of the
hierarchy is similar to that used by `rst-adjust-section'."
(interactive "P")
(rst-reset-section-caches)
- (let ((ttls (rst-all-ttls))
- (hier (rst-hdr-hierarchy))
- (region-beg (save-excursion
- (goto-char (region-beginning))
- (line-beginning-position)))
- (region-end (save-excursion
- (goto-char (region-end))
- (line-beginning-position)))
- marker-list)
-
- ;; Skip the markers that come before the region beginning.
- (while (and ttls (< (rst-Ttl-get-title-beginning (car ttls)) region-beg))
- (setq ttls (cdr ttls)))
-
- ;; Create a list of markers for all the adornments which are found within
- ;; the region.
+ (let* ((beg (region-beginning))
+ (end (region-end))
+ (ttls-reg (cl-remove-if-not
+ #'(lambda (ttl)
+ (and
+ (>= (rst-Ttl-contains ttl beg) 0)
+ (< (rst-Ttl-contains ttl end) 0)))
+ (rst-all-ttls))))
(save-excursion
- (while (and ttls (< (rst-Ttl-get-title-beginning (car ttls)) region-end))
- (push (cons (copy-marker (rst-Ttl-get-title-beginning (car ttls)))
- (rst-Ttl-hdr (car ttls))) marker-list)
- (setq ttls (cdr ttls)))
-
;; Apply modifications.
- (dolist (p marker-list)
- ;; Go to the adornment to promote.
- (goto-char (car p))
+ (rst-destructuring-dolist
+ ((marker &rest hdr
+ &aux (hier (rst-hdr-hierarchy)))
+ (mapcar #'(lambda (ttl)
+ (cons (copy-marker (rst-Ttl-get-title-beginning ttl))
+ (rst-Ttl-hdr ttl)))
+ ttls-reg))
+ (set-marker
+ (goto-char marker) nil)
;; `rst-next-hdr' cannot return nil because we apply to a section
;; header so there is some hierarchy.
- (rst-update-section (rst-next-hdr (cdr p) hier nil demote))
-
- ;; Clear marker to avoid slowing down the editing after we're done.
- (set-marker (car p) nil))
+ (rst-update-section (rst-next-hdr hdr hier nil demote)))
(setq deactivate-mark nil))))
(defun rst-display-hdr-hierarchy ()
+ ;; testcover: ok.
"Display the current file's section title adornments hierarchy.
Hierarchy is displayed in a temporary buffer."
(interactive)
@@ -2333,7 +2255,7 @@ Hierarchy is displayed in a temporary buffer."
(rst-update-section hdr)
(goto-char (point-max))
(insert "\n")
- (incf level))))))
+ (cl-incf level))))))
;; Maintain an alias for backward compatibility.
(defalias 'rst-display-adornments-hierarchy 'rst-display-hdr-hierarchy)
@@ -2341,6 +2263,7 @@ Hierarchy is displayed in a temporary buffer."
;; FIXME: Should accept an argument giving the hierarchy level to start with
;; instead of the top of the hierarchy.
(defun rst-straighten-sections ()
+ ;; testcover: ok.
"Redo the adornments of all section titles in the current buffer.
This is done using the preferred set of adornments. This can be
used, for example, when using somebody else's copy of a document,
@@ -2348,17 +2271,17 @@ in order to adapt it to our preferred style."
(interactive)
(rst-reset-section-caches)
(save-excursion
- (dolist (ttl-marker (mapcar
- (lambda (ttl)
- (cons ttl (copy-marker
- (rst-Ttl-get-title-beginning ttl))))
- (rst-all-ttls-with-level)))
- ;; Go to the appropriate position.
- (goto-char (cdr ttl-marker))
- (rst-update-section (nth (rst-Ttl-level (car ttl-marker))
- (rst-Hdr-preferred-adornments)))
- ;; Reset the marker to avoid slowing down editing.
- (set-marker (cdr ttl-marker) nil))))
+ (rst-destructuring-dolist
+ ((marker &rest level)
+ (mapcar
+ (cl-function
+ (lambda ((ttl &rest level))
+ ;; Use markers so edits don't disturb the position.
+ (cons (copy-marker (rst-Ttl-get-title-beginning ttl)) level)))
+ (rst-all-ttls-with-level)))
+ (set-marker
+ (goto-char marker) nil)
+ (rst-update-section (nth level (rst-Hdr-preferred-adornments))))))
;; Maintain an alias for compatibility.
(defalias 'rst-straighten-adornments 'rst-straighten-sections)
@@ -2367,9 +2290,9 @@ in order to adapt it to our preferred style."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Insert list items
-; Borrowed from a2r.el (version 1.3), by Lawrence Mitchell <address@hidden>.
-; I needed to make some tiny changes to the functions, so I put it here.
-; -- Wei-Wei Guo
+;; Borrowed from a2r.el (version 1.3), by Lawrence Mitchell <address@hidden>.
I
+;; needed to make some tiny changes to the functions, so I put it here.
+;; -- Wei-Wei Guo
(defconst rst-arabic-to-roman
'((1000 . "M") (900 . "CM") (500 . "D") (400 . "CD")
@@ -2378,73 +2301,59 @@ in order to adapt it to our preferred style."
(1 . "I"))
"List of maps between Arabic numbers and their Roman numeral equivalents.")
-(defun rst-arabic-to-roman (num &optional arg)
+(defun rst-arabic-to-roman (num)
+ ;; testcover: ok.
"Convert Arabic number NUM to its Roman numeral representation.
Obviously, NUM must be greater than zero. Don't blame me, blame the
Romans, I mean \"what have the Romans ever _done_ for /us/?\" (with
-apologies to Monty Python).
-If optional ARG is non-nil, insert in current buffer."
+apologies to Monty Python)."
+ (cl-check-type num (integer 1 *))
(let ((map rst-arabic-to-roman)
- res)
+ (r ""))
(while (and map (> num 0))
- (if (or (= num (caar map))
- (> num (caar map)))
- (setq res (concat res (cdar map))
- num (- num (caar map)))
- (setq map (cdr map))))
- (if arg (insert (or res "")) res)))
-
-(defun rst-roman-to-arabic (string &optional arg)
+ (cl-destructuring-bind ((val &rest sym) &rest next) map
+ (if (>= num val)
+ (setq r (concat r sym)
+ num (- num val))
+ (setq map next))))
+ r))
+
+(defun rst-roman-to-arabic (string)
+ ;; testcover: ok.
"Convert STRING of Roman numerals to an Arabic number.
-
If STRING contains a letter which isn't a valid Roman numeral,
the rest of the string from that point onwards is ignored.
-
Hence:
MMD == 2500
and
-MMDFLXXVI == 2500.
-If optional ARG is non-nil, insert in current buffer."
+MMDFLXXVI == 2500."
+ (cl-check-type string string)
+ (cl-check-type string (satisfies (lambda (s)
+ (not (equal s ""))))
+ "Roman number may not be an empty string.")
(let ((res 0)
(map rst-arabic-to-roman))
- (while map
- (if (string-match (concat "^" (cdar map)) string)
- (setq res (+ res (caar map))
- string (replace-match "" nil t string))
- (setq map (cdr map))))
- (if arg (insert res) res)))
+ (save-match-data
+ (while map
+ (cl-destructuring-bind ((val &rest sym) &rest next) map
+ (if (string-match (concat "^" sym) string)
+ (setq res (+ res val)
+ string (replace-match "" nil t string))
+ (setq map next))))
+ (cl-check-type string (satisfies (lambda (s)
+ (equal s "")))
+ "Invalid characters in roman number")
+ res)))
;; End of borrow.
-(defun rst-find-pfx-in-region (beg end pfx-re)
- "Find all the positions of prefixes in region between BEG and END.
-This is used to find bullets and enumerated list items. PFX-RE is
-a regular expression for matching the lines after indentation
-with items. Returns a list of cons cells consisting of the point
-and the column of the point."
- (let ((pfx ()))
- (save-excursion
- (goto-char beg)
- (while (< (point) end)
- (back-to-indentation)
- (when (and
- (looking-at pfx-re) ; pfx found and...
- (let ((pfx-col (current-column)))
- (save-excursion
- (forward-line -1) ; ...previous line is...
- (back-to-indentation)
- (or (looking-at (rst-re 'lin-end)) ; ...empty,
- (> (current-column) pfx-col) ; ...deeper level, or
- (and (= (current-column) pfx-col)
- (looking-at pfx-re)))))) ; ...pfx at same level.
- (push (cons (point) (current-column))
- pfx))
- (forward-line 1)))
- (nreverse pfx)))
-
-(defun rst-insert-list-pos (newitem)
- "Arrange relative position of a newly inserted list item of style NEWITEM.
+;; FIXME: All the following code should not consider single lines as items but
+;; paragraphs as reST does.
+
+(defun rst-insert-list-new-tag (tag)
+ ;; testcover: ok.
+ "Insert first item of a new list tagged with TAG.
Adding a new list might consider three situations:
@@ -2460,45 +2369,42 @@ When not (a), first forward point to the end of the
line, and add two
blank lines, then add the new list.
Other situations are just ignored and left to users themselves."
- (if (save-excursion
- (beginning-of-line)
- (looking-at (rst-re 'lin-end)))
- (if (save-excursion
- (forward-line -1)
- (looking-at (rst-re 'lin-end)))
- (insert newitem " ")
- (insert "\n" newitem " "))
+ ;; FIXME: Following line is not considered at all.
+ (let ((pfx-nls
+ ;; FIXME: Doesn't work properly for white-space line. See
+ ;; `rst-insert-list-new-BUGS'.
+ (if (rst-forward-line-looking-at 0 'lin-end)
+ (if (not (rst-forward-line-looking-at -1 'lin-end #'not))
+ 0
+ 1)
+ 2)))
(end-of-line)
- (insert "\n\n" newitem " ")))
-
-;; FIXME: Isn't this a `defconst'?
-(defvar rst-initial-enums
- (let (vals)
- (dolist (fmt '("%s." "(%s)" "%s)"))
- (dolist (c '("1" "a" "A" "I" "i"))
- (push (format fmt c) vals)))
- (cons "#." (nreverse vals)))
- "List of initial enumerations.")
-
-;; FIXME: Isn't this a `defconst'?
-(defvar rst-initial-items
- (append (mapcar 'char-to-string rst-bullets) rst-initial-enums)
+ ;; FIXME: The indentation is not fixed to a single space by the syntax. May
+ ;; be this should be configurable or rather taken from the context.
+ (insert (make-string pfx-nls ?\n) tag " ")))
+
+(defconst rst-initial-items
+ (append (mapcar #'char-to-string rst-bullets)
+ (let (vals)
+ (dolist (fmt '("%s." "(%s)" "%s)"))
+ (dolist (c '("#" "1" "a" "A" "I" "i"))
+ (push (format fmt c) vals)))
+ (nreverse vals)))
"List of initial items. It's a collection of bullets and enumerations.")
(defun rst-insert-list-new-item ()
+ ;; testcover: ok.
"Insert a new list item.
User is asked to select the item style first, for example (a), i), +.
Use TAB for completion and choices.
If user selects bullets or #, it's just added with position arranged by
-`rst-insert-list-pos'.
+`rst-insert-list-new-tag'.
If user selects enumerations, a further prompt is given. User need to
input a starting item, for example 'e' for 'A)' style. The position is
-also arranged by `rst-insert-list-pos'."
- (interactive)
- ;; FIXME: Make this comply to `interactive' standards.
+also arranged by `rst-insert-list-new-tag'."
(let* ((itemstyle (completing-read
"Select preferred item style [#.]: "
rst-initial-items nil t nil nil "#."))
@@ -2506,7 +2412,6 @@ also arranged by `rst-insert-list-pos'."
(match-string 0 itemstyle)))
(no
(save-match-data
- ;; FIXME: Make this comply to `interactive' standards.
(cond
((equal cnt "a")
(let ((itemno (read-string "Give starting value [a]: "
@@ -2527,66 +2432,73 @@ also arranged by `rst-insert-list-pos'."
(number-to-string itemno)))))))
(if no
(setq itemstyle (replace-match no t t itemstyle)))
- (rst-insert-list-pos itemstyle)))
+ (rst-insert-list-new-tag itemstyle)))
(defcustom rst-preferred-bullets
'(?* ?- ?+)
"List of favorite bullets."
:group 'rst
:type `(repeat
- (choice ,@(mapcar (lambda (char)
- (list 'const
- :tag (char-to-string char) char))
+ (choice ,@(mapcar #'(lambda (char)
+ (list 'const
+ :tag (char-to-string char) char))
rst-bullets)))
:package-version '(rst . "1.1.0"))
(rst-testcover-defcustom)
-(defun rst-insert-list-continue (curitem prefer-roman)
- "Insert a list item with list start CURITEM including its indentation level.
-If PREFER-ROMAN roman numbering is preferred over using letters."
+(defun rst-insert-list-continue (ind tag tab prefer-roman)
+ ;; testcover: ok.
+ "Insert a new list tag after the current line according to style.
+Style is defined by indentaton IND, TAG and suffix TAB. If
+PREFER-ROMAN roman numbering is preferred over using letters."
(end-of-line)
(insert
- "\n" ; FIXME: Separating lines must be possible.
- (cond
- ((string-match (rst-re '(:alt enmaut-tag
- bul-tag)) curitem)
- curitem)
- ((string-match (rst-re 'num-tag) curitem)
- (replace-match (number-to-string
- (1+ (string-to-number (match-string 0 curitem))))
- nil nil curitem))
- ((and (string-match (rst-re 'rom-tag) curitem)
- (save-match-data
- (if (string-match (rst-re 'ltr-tag) curitem) ; Also a letter tag.
- (save-excursion
- ;; FIXME: Assumes one line list items without separating
- ;; empty lines.
- (if (and (zerop (forward-line -1))
- (looking-at (rst-re 'enmexp-beg)))
- (string-match
- (rst-re 'rom-tag)
- (match-string 0)) ; Previous was a roman tag.
- prefer-roman)) ; Don't know - use flag.
- t))) ; Not a letter tag.
- (replace-match
- (let* ((old (match-string 0 curitem))
- (new (save-match-data
- (rst-arabic-to-roman
- (1+ (rst-roman-to-arabic
- (upcase old)))))))
- (if (equal old (upcase old))
- (upcase new)
- (downcase new)))
- t nil curitem))
- ((string-match (rst-re 'ltr-tag) curitem)
- (replace-match (char-to-string
- (1+ (string-to-char (match-string 0 curitem))))
- nil nil curitem)))))
+ ;; FIXME: Separating lines must be possible.
+ "\n"
+ ind
+ (save-match-data
+ (if (not (string-match (rst-re 'cntexp-tag) tag))
+ tag
+ (let ((pfx (substring tag 0 (match-beginning 0)))
+ (cnt (match-string 0 tag))
+ (sfx (substring tag (match-end 0))))
+ (concat
+ pfx
+ (cond
+ ((string-match (rst-re 'num-tag) cnt)
+ (number-to-string (1+ (string-to-number (match-string 0 cnt)))))
+ ((and
+ (string-match (rst-re 'rom-tag) cnt)
+ (save-match-data
+ (if (string-match (rst-re 'ltr-tag) cnt) ; Also a letter tag.
+ (save-excursion
+ ;; FIXME: Assumes one line list items without separating
+ ;; empty lines.
+ ;; Use of `rst-forward-line-looking-at' is very difficult
+ ;; here so don't do it.
+ (if (and (rst-forward-line-strict -1)
+ (looking-at (rst-re 'enmexp-beg)))
+ (string-match
+ (rst-re 'rom-tag)
+ (match-string 0)) ; Previous was a roman tag.
+ prefer-roman)) ; Don't know - use flag.
+ t))) ; Not a letter tag.
+ (let* ((old (match-string 0 cnt))
+ (new (rst-arabic-to-roman
+ (1+ (rst-roman-to-arabic (upcase old))))))
+ (if (equal old (upcase old))
+ (upcase new)
+ (downcase new))))
+ ((string-match (rst-re 'ltr-tag) cnt)
+ (char-to-string (1+ (string-to-char (match-string 0 cnt))))))
+ sfx))))
+ tab))
;; FIXME: At least the continuation may be folded into
;; `newline-and-indent`. However, this may not be wanted by everyone so
;; it should be possible to switch this off.
(defun rst-insert-list (&optional prefer-roman)
+ ;; testcover: ok.
"Insert a list item at the current point.
The 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
automatically. The function uses alphabetical list by default. If you want
roman numerical list, just use a prefix to set PREFER-ROMAN."
(interactive "P")
- (beginning-of-line)
- (if (looking-at (rst-re 'itmany-beg-1))
- (rst-insert-list-continue (match-string 0) prefer-roman)
- (rst-insert-list-new-item)))
+ (save-match-data
+ (1value
+ (rst-forward-line-strict 0))
+ ;; FIXME: Finds only tags in single line items. Multi-line items should be
+ ;; considered as well.
+ ;; Using `rst-forward-line-looking-at' is more complicated so don't do it.
+ (if (looking-at (rst-re 'itmany-beg-1))
+ (rst-insert-list-continue
+ (buffer-substring-no-properties
+ (match-beginning 0) (match-beginning 1))
+ (match-string 1)
+ (buffer-substring-no-properties (match-end 1) (match-end 0))
+ prefer-roman)
+ (rst-insert-list-new-item))))
+
+;; FIXME: This is wrong because it misses prefixed lines without intervening
+;; new line. See `rst-straighten-bullets-region-BUGS' and
+;; `rst-find-begs-BUGS'.
+(defun rst-find-begs (beg end rst-re-beg)
+ ;; testcover: ok.
+ "Return the positions of begs in region BEG to END.
+RST-RE-BEG is a `rst-re' argument and matched at the beginning of
+a line. Return a list of (POINT . COLUMN) where POINT gives the
+point after indentaton and COLUMN gives its column. The list is
+ordererd by POINT."
+ (let (r)
+ (save-match-data
+ (save-excursion
+ ;; FIXME refactoring: Consider making this construct a macro looping
+ ;; over the lines.
+ (goto-char beg)
+ (1value
+ (rst-forward-line-strict 0))
+ (while (< (point) end)
+ (let ((clm (current-indentation)))
+ ;; FIXME refactoring: Consider using `rst-forward-line-looking-at'.
+ (when (and
+ (looking-at (rst-re rst-re-beg)) ; Start found
+ (not (rst-forward-line-looking-at
+ -1 'lin-end
+ #'(lambda (mtcd) ; Previous line exists and is...
+ (and
+ (not mtcd) ; non-empty,
+ (<= (current-indentation) clm) ; less indented
+ (not (and (= (current-indentation) clm)
+ ; not a beg at same level.
+ (looking-at (rst-re rst-re-beg)))))))))
+ (back-to-indentation)
+ (push (cons (point) clm) r)))
+ (1value ; At least one line is moved in this loop.
+ (rst-forward-line-strict 1 end)))))
+ (nreverse r)))
(defun rst-straighten-bullets-region (beg end)
- "Make all the bulleted list items in the region consistent.
-The region is specified between BEG and END. You can use this
-after you have merged multiple bulleted lists to make them use
-the same/correct/consistent bullet characters.
-
-See variable `rst-preferred-bullets' for the list of bullets to
-adjust. If bullets are found on levels beyond the
-`rst-preferred-bullets' list, they are not modified."
+ ;; testcover: ok.
+ "Make all the bulleted list items in the region from BEG to END consistent.
+Use this after you have merged multiple bulleted lists to make
+them use the preferred bullet characters given by
+`rst-preferred-bullets' for each level. If bullets are found on
+levels beyond the `rst-preferred-bullets' list, they are not
+modified."
(interactive "r")
-
- (let ((bullets (rst-find-pfx-in-region beg end (rst-re 'bul-sta)))
- (levtable (make-hash-table :size 4)))
-
- ;; Create a map of levels to list of positions.
- (dolist (x bullets)
- (let ((key (cdr x)))
- (puthash key
- (append (gethash key levtable (list))
- (list (car x)))
- levtable)))
-
- ;; Sort this map and create a new map of prefix char and list of positions.
- (let ((poslist ())) ; List of (indent . positions).
- (maphash (lambda (x y) (push (cons x y) poslist)) levtable)
-
- (let ((bullets rst-preferred-bullets))
- (dolist (x (sort poslist 'car-less-than-car))
- (when bullets
- ;; Apply the characters.
- (dolist (pos (cdr x))
- (goto-char pos)
- (delete-char 1)
- (insert (string (car bullets))))
- (setq bullets (cdr bullets))))))))
+ (save-excursion
+ (let (clm2pnts) ; Map a column to a list of points at this column.
+ (rst-destructuring-dolist
+ ((point &rest column
+ &aux (found (assoc column clm2pnts)))
+ (rst-find-begs beg end 'bul-beg))
+ (if found
+ ;;; (push point (cdr found)) ; FIXME: Doesn't work with `testcover'.
+ (setcdr found (cons point (cdr found))) ; Synonym.
+ (push (list column point) clm2pnts)))
+ (rst-destructuring-dolist
+ ((bullet _clm &rest pnts)
+ ;; Zip preferred bullets and sorted columns associating a bullet
+ ;; with a column and all the points this column is found.
+ (cl-mapcar #'(lambda (bullet clm2pnt)
+ (cons bullet clm2pnt))
+ rst-preferred-bullets
+ (sort clm2pnts #'car-less-than-car)))
+ ;; Replace the bullets by the preferred ones.
+ (dolist (pnt pnts)
+ (goto-char pnt)
+ ;; FIXME: Assumes bullet to replace is a single char.
+ (delete-char 1)
+ (insert bullet))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Table of contents
(defun rst-all-stn ()
- "Return the hierarchical tree of section titles as a top level `rst-Stn'.
-Return nil for no section titles."
- ;; FIXME: The top level node may contain the document title instead of nil.
+ ;; testcover: ok.
+ "Return the hierarchical tree of sections as a top level `rst-Stn'.
+Return value satisfies `rst-Stn-is-top' or is nil for no
+sections."
(cdr (rst-remaining-stn (rst-all-ttls-with-level) -1)))
-(defun rst-remaining-stn (remaining lev)
- "Process the first entry of REMAINING expected to be on level LEV.
-REMAINING is the remaining list of `rst-Ttl' entries.
-Return (UNPROCESSED . NODE) for the first entry of REMAINING.
-UNPROCESSED is the list of still unprocessed entries. NODE is a
-`rst-Stn' or nil if REMAINING is empty."
- (let ((ttl (car remaining))
- (unprocessed remaining)
- fnd children)
- ;; If the current adornment matches expected level.
- (when (and ttl (= (rst-Ttl-level ttl) lev))
- ;; Consume the current entry and create the current node with it.
- (setq unprocessed (cdr remaining))
- (setq fnd ttl))
- ;; Build the child nodes as long as they have deeper level.
- (while (and unprocessed (> (rst-Ttl-level (car unprocessed)) lev))
- (let* ((rem-child (rst-remaining-stn unprocessed (1+ lev)))
- (child (cdr rem-child)))
- (when child
- (push child children))
- (setq unprocessed (car rem-child))))
- (setq children (reverse children))
- (cons unprocessed
- (if (or fnd children)
- (rst-Stn-new fnd lev children)))))
+(defun rst-remaining-stn (unprocessed expected)
+ ;; testcover: ok.
+ "Process the first entry of UNPROCESSED expected to be on level EXPECTED.
+UNPROCESSED is the remaining list of (`rst-Ttl' . LEVEL) entries.
+Return (REMAINING . STN) for the first entry of UNPROCESSED.
+REMAINING is the list of still unprocessed entries. STN is a
+`rst-Stn' or nil if UNPROCESSED is empty."
+ (if (not unprocessed)
+ (1value
+ (cons nil nil))
+ (cl-destructuring-bind
+ ((ttl &rest level) &rest next
+ &aux fnd children)
+ unprocessed
+ (when (= level expected)
+ ;; Consume the current entry and create the current node with it.
+ (setq fnd ttl)
+ (setq unprocessed next))
+ ;; Build the child nodes as long as they have deeper level.
+ (while (and unprocessed (> (cdar unprocessed) expected))
+ (cl-destructuring-bind (remaining &rest stn)
+ (rst-remaining-stn unprocessed (1+ expected))
+ (when stn
+ (push stn children))
+ (setq unprocessed remaining)))
+ (cons unprocessed
+ (when (or fnd children)
+ (rst-Stn-new fnd expected (nreverse children)))))))
(defun rst-stn-containing-point (stn &optional point)
+ ;; testcover: ok.
"Return `rst-Stn' in STN before POINT or nil if in no section.
POINT defaults to the current point. STN may be nil for no
section headers at all."
@@ -2699,15 +2662,13 @@ section headers at all."
(setq point (or point (point)))
(when (>= point (rst-Stn-get-title-beginning stn))
;; Point may be in this section or a child.
- (let ((children (rst-Stn-children stn))
- found)
- (while (and children
- (>= point (rst-Stn-get-title-beginning (car children))))
- ;; Point may be in this child.
- (setq found (car children)
- children (cdr children)))
- (if found
- (rst-stn-containing-point found point)
+ (let ((in-child (cl-find-if
+ #'(lambda (child)
+ (>= point (rst-Stn-get-title-beginning child)))
+ (rst-Stn-children stn)
+ :from-end t)))
+ (if in-child
+ (rst-stn-containing-point in-child point)
stn)))))
(defgroup rst-toc nil
@@ -2729,7 +2690,7 @@ indentation style:
- `plain': no numbering (fixed indentation)
- `fixed': numbering, but fixed indentation
- `aligned': numbering, titles aligned under each other
-- `listed': numbering, with dashes like list items (EXPERIMENTAL)"
+- `listed': titles as list items"
:type '(choice (const plain)
(const fixed)
(const aligned)
@@ -2743,143 +2704,204 @@ indentation style:
:group 'rst-toc)
(rst-testcover-defcustom)
-;; FIXME: What does this mean?
-;; This is used to avoid having to change the user's mode.
-(defvar rst-toc-insert-click-keymap
- (let ((map (make-sparse-keymap)))
- (define-key map [mouse-1] 'rst-toc-mode-mouse-goto)
- map)
- "(Internal) What happens when you click on propertized text in the TOC.")
-
(defcustom rst-toc-insert-max-level nil
"If non-nil, maximum depth of the inserted TOC."
:type '(choice (const nil) integer)
:group 'rst-toc)
(rst-testcover-defcustom)
-(defun rst-toc-insert (&optional pfxarg)
- "Insert a text rendering of the table of contents of the current section.
+(defun rst-toc-insert (&optional max-level)
+ ;; testcover: ok.
+ "Insert the table of contents of the current section at the current column.
By default the top level is ignored if there is only one, because
-we assume that the document will have a single title.
-
-If a numeric prefix argument PFXARG is given, insert the TOC up
-to the specified level.
-
-The TOC is inserted indented at the current column."
+we assume that the document will have a single title. A numeric
+prefix argument MAX-LEVEL overrides `rst-toc-insert-max-level'.
+Text in the line beyond column is deleted."
(interactive "P")
(rst-reset-section-caches)
- (let (;; Check maximum level override.
- (rst-toc-insert-max-level
- (if (and (integerp pfxarg) (> (prefix-numeric-value pfxarg) 0))
- (prefix-numeric-value pfxarg) rst-toc-insert-max-level))
- (pt-stn (rst-stn-containing-point (rst-all-stn)))
- ;; Figure out initial indent.
- (initial-indent (make-string (current-column) ? ))
- (init-point (point)))
- (when (and pt-stn (rst-Stn-children pt-stn))
- (rst-toc-insert-node pt-stn 0 initial-indent "")
- ;; FIXME: Really having the last newline would be better.
- ;; Delete the last newline added.
- (delete-char -1))))
-
-(defun rst-toc-insert-node (stn level indent pfx)
- "Insert STN in table-of-contents.
-LEVEL is the depth level of the sections in the tree currently
-rendered. INDENT is the indentation string. PFX is the prefix
-numbering, that includes the alignment necessary for all the
-children of level to align."
- ;; Note: we do child numbering from the parent, so we start number the
- ;; children one level before we print them.
- (when (> level 0)
- (unless (> (current-column) 0)
- ;; No indent yet - insert it.
- (insert indent))
- (let ((beg (point)))
- (unless (equal rst-toc-insert-style 'plain)
- (insert pfx rst-toc-insert-number-separator))
- (insert (rst-Stn-get-text stn))
- ;; Add properties to the text, even though in normal text mode it
- ;; won't be doing anything for now. Not sure that I want to change
- ;; mode stuff. At least the highlighting gives the idea that this
- ;; is generated automatically.
- (put-text-property beg (point) 'mouse-face 'highlight)
- (put-text-property
- beg (point) 'rst-toc-target
- (set-marker (make-marker) (rst-Stn-get-title-beginning stn)))
- (put-text-property beg (point) 'keymap rst-toc-insert-click-keymap))
+ (let ((pt-stn (rst-stn-containing-point (rst-all-stn))))
+ (when pt-stn
+ (let ((max
+ (if (and (integerp max-level)
+ (> (prefix-numeric-value max-level) 0))
+ (prefix-numeric-value max-level)
+ rst-toc-insert-max-level))
+ (ind (current-column))
+ (buf (current-buffer))
+ (tabs indent-tabs-mode) ; Copy buffer local value.
+ txt)
+ (setq txt
+ ;; Render to temporary buffer so markers are created correctly.
+ (with-temp-buffer
+ (rst-toc-insert-tree pt-stn buf rst-toc-insert-style max
+ rst-toc-link-keymap nil)
+ (goto-char (point-min))
+ (when (rst-forward-line-strict 1)
+ ;; There are lines to indent.
+ (let ((indent-tabs-mode tabs))
+ (indent-rigidly (point) (point-max) ind)))
+ (buffer-string)))
+ (unless (zerop (length txt))
+ ;; Delete possible trailing text.
+ (delete-region (point) (line-beginning-position 2))
+ (insert txt)
+ (backward-char 1))))))
+
+(defun rst-toc-insert-link (pfx stn buf keymap)
+ ;; testcover: ok.
+ "Insert text of STN in BUF as a linked section reference at point.
+If KEYMAP use this as keymap property. PFX is inserted before text."
+ (let ((beg (point)))
+ (insert pfx)
+ (insert (rst-Stn-get-text stn))
+ (put-text-property beg (point) 'mouse-face 'highlight)
(insert "\n")
- ;; Prepare indent for children.
- (setq indent
- (cond
- ((eq rst-toc-insert-style 'plain)
- (concat indent (make-string rst-toc-indent ? )))
- ((eq rst-toc-insert-style 'fixed)
- (concat indent (make-string rst-toc-indent ? )))
- ((eq rst-toc-insert-style 'aligned)
- (concat indent (make-string (+ (length pfx) 2) ? )))
- ((eq rst-toc-insert-style 'listed)
- (concat (substring indent 0 -3)
- (concat (make-string (+ (length pfx) 2) ? ) " - "))))))
- (when (or (eq rst-toc-insert-max-level nil)
- (< level rst-toc-insert-max-level))
- (let ((count 1)
- fmt)
- ;; Add a separating dot if there is already a prefix.
- (when (> (length pfx) 0)
- (string-match (rst-re "[ \t\n]*\\'") pfx)
- (setq pfx (concat (replace-match "" t t pfx) ".")))
- ;; Calculate the amount of space that the prefix will require
- ;; for the numbers.
- (when (rst-Stn-children stn)
- (setq fmt
- (format "%%-%dd"
- (1+ (floor (log (length (rst-Stn-children stn))
- 10))))))
- (dolist (child (rst-Stn-children stn))
- (rst-toc-insert-node child (1+ level) indent
- (concat pfx (format fmt count)))
- (incf count)))))
+ (put-text-property
+ beg (point) 'rst-toc-target
+ (set-marker (make-marker) (rst-Stn-get-title-beginning stn) buf))
+ (when keymap
+ (put-text-property beg (point) 'keymap keymap))))
+
+(defun rst-toc-get-link (link-buf link-pnt)
+ ;; testcover: ok.
+ "Return the link from text property at LINK-PNT in LINK-BUF."
+ (let ((mrkr (get-text-property link-pnt 'rst-toc-target link-buf)))
+ (unless mrkr
+ (error "No section on this line"))
+ (unless (buffer-live-p (marker-buffer mrkr))
+ (error "Buffer for this section was killed"))
+ mrkr))
+
+(defconst rst-toc-link-keymap
+ (let ((map (make-sparse-keymap)))
+ (define-key map [mouse-1] 'rst-toc-mouse-follow-link)
+ map)
+ "Keymap used for links in TOC.")
+
+(defun rst-toc-insert-tree (stn buf style depth keymap tgt-stn)
+ ;; testcover: ok.
+ "Insert table of contents of tree below top node STN in buffer BUF.
+STYLE is the style to use and must be one of the symbols allowed
+for `rst-toc-insert-style'. DEPTH is the maximum relative depth
+from STN to insert or nil for no maximum depth. See
+`rst-toc-insert-link' for KEYMAP. Return beginning of title line
+if TGT-STN is rendered or nil if not rendered or TGT-STN is nil.
+Just return nil if STN is nil."
+ (when stn
+ (rst-toc-insert-children (rst-Stn-children stn) buf style depth 0 "" keymap
+ tgt-stn)))
+
+(defun rst-toc-insert-children (children buf style depth indent numbering
+ keymap tgt-stn)
+ ;; testcover: ok.
+ "In the current buffer at point insert CHILDREN in BUF to table of contents.
+See `rst-toc-insert-tree' for STYLE, DEPTH and TGT-STN. See
+`rst-toc-insert-stn' for INDENT and NUMBERING. See
+`rst-toc-insert-link' for KEYMAP."
+ (let ((count 1)
+ ;; Child numbering is done from the parent.
+ (num-fmt (format "%%%dd"
+ (1+ (floor (log (1+ (length children)) 10)))))
+ fnd)
+ (when (not (equal numbering ""))
+ ;; Add separating dot to existing numbering.
+ (setq numbering (concat numbering ".")))
+ (dolist (child children fnd)
+ (setq fnd
+ (or (rst-toc-insert-stn child buf style depth indent
+ (concat numbering (format num-fmt count))
+ keymap tgt-stn) fnd))
+ (cl-incf count))))
+
+;; FIXME refactoring: Use `rst-Stn-buffer' instead of `buf'.
+(defun rst-toc-insert-stn (stn buf style depth indent numbering keymap tgt-stn)
+ ;; testcover: ok.
+ "In the current buffer at point insert STN in BUF into table of contents.
+See `rst-toc-insert-tree' for STYLE, DEPTH and TGT-STN. INDENT
+is the indentation depth to use for STN. NUMBERING is the prefix
+numbering for STN. See `rst-toc-insert-link' for KEYMAP."
+ (when (or (not depth) (> depth 0))
+ (cl-destructuring-bind
+ (pfx add
+ &aux (fnd (when (and tgt-stn
+ (equal (rst-Stn-get-title-beginning stn)
+ (rst-Stn-get-title-beginning tgt-stn)))
+ (point))))
+ (cond
+ ((eq style 'plain)
+ (list "" rst-toc-indent))
+ ((eq style 'fixed)
+ (list (concat numbering rst-toc-insert-number-separator)
+ rst-toc-indent))
+ ((eq style 'aligned)
+ (list (concat numbering rst-toc-insert-number-separator)
+ (+ (length numbering)
+ (length rst-toc-insert-number-separator))))
+ ((eq style 'listed)
+ (list (format "%c " (car rst-preferred-bullets)) 2)))
+ ;; Indent using spaces so buffer characteristics like `indent-tabs-mode'
+ ;; do not matter.
+ (rst-toc-insert-link (concat (make-string indent ? ) pfx) stn buf keymap)
+ (or (rst-toc-insert-children (rst-Stn-children stn) buf style
+ (when depth
+ (1- depth))
+ (+ indent add) numbering keymap tgt-stn)
+ fnd))))
(defun rst-toc-update ()
+ ;; testcover: ok.
"Automatically find the contents section of a document and update.
Updates the inserted TOC if present. You can use this in your
file-write hook to always make it up-to-date automatically."
(interactive)
- (save-excursion
- ;; Find and delete an existing comment after the first contents directive.
- ;; Delete that region.
- (goto-char (point-min))
- ;; We look for the following and the following only (in other words, if
your
- ;; syntax differs, this won't work.).
- ;;
- ;; .. contents:: [...anything here...]
- ;; [:field: value]...
- ;; ..
- ;; XXXXXXXX
- ;; XXXXXXXX
- ;; [more lines]
- (let ((beg (re-search-forward
- (rst-re "^" 'exm-sta "contents" 'dcl-tag ".*\n"
- "\\(?:" 'hws-sta 'fld-tag ".*\n\\)*" 'exm-tag) nil t))
- last-real)
- (when beg
- ;; Look for the first line that starts at the first column.
- (forward-line 1)
- (while (and
- (< (point) (point-max))
- (or (if (looking-at
- (rst-re 'hws-sta "\\S ")) ; indented content.
- (setq last-real (point)))
- (looking-at (rst-re 'lin-end)))) ; empty line.
- (forward-line 1))
- (if last-real
- (progn
- (goto-char last-real)
- (end-of-line)
- (delete-region beg (point)))
- (goto-char beg))
- (insert "\n ")
- (rst-toc-insert))))
+ (save-match-data
+ (save-excursion
+ ;; Find and delete an existing comment after the first contents
+ ;; directive. Delete that region.
+ (goto-char (point-min))
+ ;; FIXME: Should accept indentation of the whole block.
+ ;; We look for the following and the following only (in other words, if
+ ;; your syntax differs, this won't work.).
+ ;;
+ ;; .. contents:: [...anything here...]
+ ;; [:field: value]...
+ ;; ..
+ ;; XXXXXXXX
+ ;; XXXXXXXX
+ ;; [more lines]
+ ;; FIXME: Works only for the first of these tocs. There should be a
+ ;; fixed text after the comment such as "RST-MODE ELECTRIC TOC".
+ ;; May be parameters such as `max-level' should be appended.
+ (let ((beg (re-search-forward
+ (1value
+ (rst-re "^" 'exm-sta "contents" 'dcl-tag ".*\n"
+ "\\(?:" 'hws-sta 'fld-tag ".*\n\\)*" 'exm-tag))
+ nil t))
+ fnd)
+ (when
+ (and beg
+ (rst-forward-line-looking-at
+ 1 'lin-end
+ #'(lambda (mtcd)
+ (unless mtcd
+ (rst-apply-indented-blocks
+ (point) (point-max) (current-indentation)
+ #'(lambda (count _in-first _in-sub in-super in-empty
+ _relind)
+ (cond
+ ((or (> count 1) in-super))
+ ((not in-empty)
+ (setq fnd (line-end-position))
+ nil)))))
+ t)))
+ (when fnd
+ (delete-region beg fnd))
+ (goto-char beg)
+ (insert "\n ")
+ ;; FIXME: Ignores an `max-level' given to the original
+ ;; `rst-toc-insert'. `max-level' could be rendered to the first
+ ;; line.
+ (rst-toc-insert)))))
;; Note: always return nil, because this may be used as a hook.
nil)
@@ -2891,58 +2913,26 @@ file-write hook to always make it up-to-date
automatically."
;; ;; Disable undo for the write file hook.
;; (let ((buffer-undo-list t)) (rst-toc-update) ))
-(defalias 'rst-toc-insert-update 'rst-toc-update) ; backwards compat.
+;; Maintain an alias for compatibility.
+(defalias 'rst-toc-insert-update 'rst-toc-update)
-(defun rst-toc-node (stn buf target)
- "Insert STN in the table-of-contents of buffer BUF.
-If TARGET is given and this call renders a `rst-Stn' at the same
-location return position of beginning of line. Otherwise return
-nil."
- (let ((beg (point))
- fnd)
- (if (or (not stn) (rst-Stn-is-top stn))
- (progn
- (insert (format "Table of Contents:\n"))
- (put-text-property beg (point)
- 'face (list '(background-color . "gray"))))
- (when (and target
- (equal (rst-Stn-get-title-beginning stn)
- (rst-Stn-get-title-beginning target)))
- (setq fnd beg))
- (insert (make-string (* rst-toc-indent (rst-Stn-level stn)) ? ))
- (insert (rst-Stn-get-text stn))
- ;; Highlight lines.
- (put-text-property beg (point) 'mouse-face 'highlight)
- (insert "\n")
- ;; Add link on lines.
- (put-text-property
- beg (point) 'rst-toc-target
- (set-marker (make-marker) (rst-Stn-get-title-beginning stn) buf)))
- (when stn
- (dolist (child (rst-Stn-children stn))
- (setq fnd (or (rst-toc-node child buf target) fnd))))
- fnd))
-
-(defvar rst-toc-buffer-name "*Table of Contents*"
+(defconst rst-toc-buffer-name "*Table of Contents*"
"Name of the Table of Contents buffer.")
-(defvar rst-toc-return-wincfg nil
+(defvar-local rst-toc-mode-return-wincfg nil
"Window configuration to which to return when leaving the TOC.")
(defun rst-toc ()
- "Display a table-of-contents.
-Finds all the section titles and their adornments in the
-file, and displays a hierarchically-organized list of the
-titles, which is essentially a table-of-contents of the
-document.
-
-The Emacs buffer can be navigated, and selecting a section
-brings the cursor in that section."
+ ;; testcover: ok.
+ "Display a table of contents for current buffer.
+Displays all section titles found in the current buffer in a
+hierarchical list. The resulting buffer can be navigated, and
+selecting a section title moves the cursor to that section."
(interactive)
(rst-reset-section-caches)
(let* ((wincfg (list (current-window-configuration) (point-marker)))
(sectree (rst-all-stn))
- (target-node (rst-stn-containing-point sectree))
+ (target-stn (rst-stn-containing-point sectree))
(target-buf (current-buffer))
(buf (get-buffer-create rst-toc-buffer-name))
target-pos)
@@ -2950,134 +2940,174 @@ brings the cursor in that section."
(let ((inhibit-read-only t))
(rst-toc-mode)
(delete-region (point-min) (point-max))
- (setq target-pos (rst-toc-node sectree target-buf target-node))))
+ ;; FIXME: Could use a customizable style.
+ (setq target-pos (rst-toc-insert-tree
+ sectree target-buf 'plain nil nil target-stn))))
(display-buffer buf)
(pop-to-buffer buf)
- (setq-local rst-toc-return-wincfg wincfg)
+ (setq rst-toc-mode-return-wincfg wincfg)
(goto-char (or target-pos (point-min)))))
-(defun rst-toc-mode-find-section ()
- "Get the section from text property at point."
- (let ((pos (get-text-property (point) 'rst-toc-target)))
- (unless pos
- (error "No section on this line"))
- (unless (buffer-live-p (marker-buffer pos))
- (error "Buffer for this section was killed"))
- pos))
+;; Maintain an alias for compatibility.
+(defalias 'rst-goto-section 'rst-toc-follow-link)
+
+(defun rst-toc-follow-link (link-buf link-pnt kill)
+ ;; testcover: ok.
+ "Follow the link to the section at LINK-PNT in LINK-BUF.
+LINK-PNT and LINK-BUF default to the point in the current buffer.
+With prefix argument KILL a TOC buffer is destroyed. Throw an
+error if there is no working link at the given position."
+ (interactive "i\nd\nP")
+ (unless link-buf
+ (setq link-buf (current-buffer)))
+ ;; Do not catch errors from `rst-toc-get-link' because otherwise the error is
+ ;; suppressed and invisible in interactve use.
+ (let ((mrkr (rst-toc-get-link link-buf link-pnt)))
+ (condition-case nil
+ (rst-toc-mode-return kill)
+ ;; Catch errors when not in `toc-mode'.
+ (error nil))
+ (pop-to-buffer (marker-buffer mrkr))
+ (goto-char mrkr)
+ ;; FIXME: Should be a customizable number of lines from beginning or end of
+ ;; window just like the argument to `recenter`. It would be ideal if
+ ;; the adornment is always completely visible.
+ (recenter 5)))
+
+;; Maintain an alias for compatibility.
+(defalias 'rst-toc-mode-goto-section 'rst-toc-mode-follow-link-kill)
;; FIXME: Cursor before or behind the list must be handled properly; before the
;; list should jump to the top and behind the list to the last normal
;; paragraph.
-(defun rst-goto-section (&optional kill)
- "Go to the section the current line describes.
-If KILL a TOC buffer is destroyed."
+(defun rst-toc-mode-follow-link-kill ()
+ ;; testcover: ok.
+ "Follow the link to the section at point and kill the TOC buffer."
(interactive)
- (let ((pos (rst-toc-mode-find-section)))
- (when kill
- ;; FIXME: This should rather go to `rst-toc-mode-goto-section'.
- (set-window-configuration (car rst-toc-return-wincfg))
- (kill-buffer (get-buffer rst-toc-buffer-name)))
- (pop-to-buffer (marker-buffer pos))
- (goto-char pos)
- ;; FIXME: make the recentering conditional on scroll.
- (recenter 5)))
+ (rst-toc-follow-link (current-buffer) (point) t))
-(defun rst-toc-mode-goto-section ()
- "Go to the section the current line describes and kill the TOC buffer."
- (interactive)
- (rst-goto-section t))
+;; Maintain an alias for compatibility.
+(defalias 'rst-toc-mode-mouse-goto 'rst-toc-mouse-follow-link)
-(defun rst-toc-mode-mouse-goto (event)
+(defun rst-toc-mouse-follow-link (event kill)
+ ;; testcover: uncovered.
"In `rst-toc' mode, go to the occurrence whose line you click on.
-EVENT is the input event."
- (interactive "e")
- (let ((pos
- (with-current-buffer (window-buffer (posn-window (event-end event)))
- (save-excursion
- (goto-char (posn-point (event-end event)))
- (rst-toc-mode-find-section)))))
- (pop-to-buffer (marker-buffer pos))
- (goto-char pos)
- (recenter 5)))
+EVENT is the input event. Kill TOC buffer if KILL."
+ (interactive "e\ni")
+ (rst-toc-follow-link (window-buffer (posn-window (event-end event)))
+ (posn-point (event-end event)) kill))
+
+;; Maintain an alias for compatibility.
+(defalias 'rst-toc-mode-mouse-goto-kill 'rst-toc-mode-mouse-follow-link-kill)
-(defun rst-toc-mode-mouse-goto-kill (event)
- "Same as `rst-toc-mode-mouse-goto', but kill TOC buffer as well.
+(defun rst-toc-mode-mouse-follow-link-kill (event)
+ ;; testcover: uncovered.
+ "Same as `rst-toc-mouse-follow-link', but kill TOC buffer as well.
EVENT is the input event."
(interactive "e")
- (call-interactively 'rst-toc-mode-mouse-goto event)
- (kill-buffer (get-buffer rst-toc-buffer-name)))
+ (rst-toc-mouse-follow-link event t))
+
+;; Maintain an alias for compatibility.
+(defalias 'rst-toc-quit-window 'rst-toc-mode-return)
+
+(defun rst-toc-mode-return (kill)
+ ;; testcover: ok.
+ "Leave the current TOC buffer and return to the previous environment.
+With prefix argument KILL non-nil, kill the buffer instead of
+burying it."
+ (interactive "P")
+ (unless rst-toc-mode-return-wincfg
+ (error "Not in a `toc-mode' buffer"))
+ (cl-destructuring-bind
+ (wincfg pos
+ &aux (toc-buf (current-buffer)))
+ rst-toc-mode-return-wincfg
+ (set-window-configuration wincfg)
+ (goto-char pos)
+ (if kill
+ (kill-buffer toc-buf)
+ (bury-buffer toc-buf))))
-(defun rst-toc-quit-window ()
- "Leave the current TOC buffer."
+(defun rst-toc-mode-return-kill ()
+ ;; testcover: uncovered.
+ "Like `rst-toc-mode-return' but kill TOC buffer."
(interactive)
- (let ((retbuf rst-toc-return-wincfg))
- (set-window-configuration (car retbuf))
- (goto-char (cadr retbuf))))
+ (rst-toc-mode-return t))
(defvar rst-toc-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map [mouse-1] 'rst-toc-mode-mouse-goto-kill)
- ;; FIXME: This very useful function must be on some key.
- (define-key map [mouse-2] 'rst-toc-mode-mouse-goto)
- (define-key map "\C-m" 'rst-toc-mode-goto-section)
- (define-key map "f" 'rst-toc-mode-goto-section)
- (define-key map "q" 'rst-toc-quit-window)
- ;; FIXME: Killing should clean up like `rst-toc-quit-window' does.
- (define-key map "z" 'kill-this-buffer)
+ (define-key map [mouse-1] #'rst-toc-mode-mouse-follow-link-kill)
+ (define-key map [mouse-2] #'rst-toc-mouse-follow-link)
+ (define-key map "\C-m" #'rst-toc-mode-follow-link-kill)
+ (define-key map "f" #'rst-toc-mode-follow-link-kill)
+ (define-key map "n" #'next-line)
+ (define-key map "p" #'previous-line)
+ (define-key map "q" #'rst-toc-mode-return)
+ (define-key map "z" #'rst-toc-mode-return-kill)
map)
"Keymap for `rst-toc-mode'.")
-(put 'rst-toc-mode 'mode-class 'special)
-
-;; Could inherit from the new `special-mode'.
-(define-derived-mode rst-toc-mode nil "ReST-TOC"
+(define-derived-mode rst-toc-mode special-mode "ReST-TOC"
"Major mode for output from \\[rst-toc], the table-of-contents for the
document.
-
\\{rst-toc-mode-map}"
- (setq buffer-read-only t))
+ ;; FIXME: `revert-buffer-function` must be defined so `revert-buffer` works
+ ;; as expected for a special mode. In particular the referred buffer
+ ;; needs to be rescanned and the TOC must be updated accordingly.
+ ;; FIXME: Should contain the name of the buffer this is the toc of.
+ (setq header-line-format "Table of Contents"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Section movement
-(defun rst-forward-section (&optional offset)
- "Skip to the next reStructuredText section title.
-OFFSET specifies how many titles to skip. Use a negative OFFSET
-to move backwards in the file (default is to use 1)."
- (interactive)
+;; FIXME testcover: Use `testcover'. Mark up a function with sufficient test
+;; coverage by a comment tagged with `testcover' after the
+;; `defun'. Then move this comment.
+
+(defun rst-forward-section (offset)
+ "Jump forward OFFSET section titles ending up at the start of the title line.
+OFFSET defaults to 1 and may be negative to move backward. An
+OFFSET of 0 does not move unless point is inside a title. Go to
+end or beginning of buffer if no more section titles in the desired
+direction."
+ (interactive "p")
(rst-reset-section-caches)
- (let* ((offset (or offset 1))
- (ttls (rst-all-ttls))
- (curpos (line-beginning-position))
- (cur ttls)
- (idx 0)
- ttl)
-
- ;; Find the index of the "next" adornment with respect to the current line.
- (while (and cur (< (rst-Ttl-get-title-beginning (car cur)) curpos))
- (setq cur (cdr cur))
- (incf idx))
- ;; `cur' is the `rst-Ttl' on or following the current line.
-
- (if (and (> offset 0) cur
- (equal (rst-Ttl-get-title-beginning (car cur)) curpos))
- (incf idx))
-
- ;; Find the final index.
- (setq idx (+ idx (if (> offset 0) (- offset 1) offset)))
- (setq ttl (nth idx ttls))
+ (let* ((ttls (rst-all-ttls))
+ (count (length ttls))
+ (pnt (point))
+ (contained nil) ; Title contains point (or is after point otherwise).
+ (found (or (cl-position-if
+ ;; Find a title containing or after point.
+ #'(lambda (ttl)
+ (let ((cmp (rst-Ttl-contains ttl pnt)))
+ (cond
+ ((= cmp 0) ; Title contains point.
+ (setq contained t)
+ t)
+ ((> cmp 0) ; Title after point.
+ t))))
+ ttls)
+ ;; Point after all titles.
+ count))
+ (target (+ found offset
+ ;; If point is in plain text found title is already one
+ ;; step forward.
+ (if (and (not contained) (>= offset 0)) -1 0))))
(goto-char (cond
- ((and ttl (>= idx 0))
- (rst-Ttl-get-title-beginning ttl))
- ((> offset 0)
+ ((< target 0)
+ (point-min))
+ ((>= target count)
(point-max))
- ((point-min))))))
+ ((and (not contained) (= offset 0))
+ ;; Point not in title and should not move - do not move.
+ pnt)
+ ((rst-Ttl-get-title-beginning (nth target ttls)))))))
-(defun rst-backward-section ()
- "Like `rst-forward-section', except move back one title."
- (interactive)
- (rst-forward-section -1))
+(defun rst-backward-section (offset)
+ "Like `rst-forward-section', except move backward by OFFSET."
+ (interactive "p")
+ (rst-forward-section (- offset)))
-;; FIXME: What is `allow-extend' for?
+;; FIXME: What is `allow-extend' for? See `mark-paragraph' for an explanation.
(defun rst-mark-section (&optional count allow-extend)
"Select COUNT sections around point.
Mark following sections for positive COUNT or preceding sections
@@ -3110,16 +3140,18 @@ The line containing the start of the region is always
considered
spanned. If the region ends at the beginning of a line this line
is not considered spanned, otherwise it is spanned."
(let (mincol)
- (save-excursion
- (goto-char beg)
- (while (< (point) end)
- (back-to-indentation)
- (unless (looking-at (rst-re 'lin-end))
- (setq mincol (if mincol
- (min mincol (current-column))
- (current-column))))
- (forward-line 1)))
- mincol))
+ (save-match-data
+ (save-excursion
+ (goto-char beg)
+ (1value
+ (rst-forward-line-strict 0))
+ (while (< (point) end)
+ (unless (looking-at (rst-re 'lin-end))
+ (setq mincol (if mincol
+ (min mincol (current-indentation))
+ (current-indentation))))
+ (rst-forward-line-strict 1 end)))
+ mincol)))
;; FIXME: At the moment only block comments with leading empty comment line are
;; 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
inner tab. I.e. a tab which does come from the basic indentation
and not from inner alignment points."
(save-excursion
- (forward-line 0)
+ (rst-forward-line-strict 0)
(save-match-data
(unless (looking-at (rst-re 'lin-end))
(back-to-indentation)
@@ -3205,7 +3237,8 @@ and not from inner alignment points."
(if (zerop rst-indent-field)
(push (list (match-end 2)
(if (string= (match-string 2) "") 1 0)
- t) tabs))))
+ t)
+ tabs))))
;; Directive.
((looking-at (rst-re 'dir-sta-3 '(:grp "\\S ") "?"))
(push (list (match-end 1) 0 t) tabs)
@@ -3223,16 +3256,18 @@ and not from inner alignment points."
(push (list (point) rst-indent-comment t) tabs)))
;; Start of literal block.
(when (looking-at (rst-re 'lit-sta-2))
- (let ((tab0 (first tabs)))
- (push (list (first tab0)
- (+ (second tab0)
+ (cl-destructuring-bind (point offset _inner) (car tabs)
+ (push (list point
+ (+ offset
(if (match-string 1)
rst-indent-literal-minimized
rst-indent-literal-normal))
- t) tabs)))
- (mapcar (lambda (tab)
- (goto-char (first tab))
- (cons (+ (current-column) (second tab)) (third tab)))
+ t)
+ tabs)))
+ (mapcar (cl-function
+ (lambda ((point offset inner))
+ (goto-char point)
+ (cons (+ (current-column) offset) inner)))
tabs))))))
(defun rst-compute-tabs (pt)
@@ -3242,38 +3277,35 @@ Return a list of tabs sorted by likeliness to continue
writing
like `rst-line-tabs'. Nearer lines have generally a higher
likeliness than farther lines. Return nil if no tab is found in
the text above."
+ ;; FIXME: See test `indent-for-tab-command-BUGS`.
(save-excursion
(goto-char pt)
(let (leftmost ; Leftmost column found so far.
innermost ; Leftmost column for inner tab.
tablist)
- (while (and (zerop (forward-line -1))
+ (while (and (rst-forward-line-strict -1)
(or (not leftmost)
(> leftmost 0)))
- (let* ((tabs (rst-line-tabs))
- (leftcol (if tabs (apply 'min (mapcar 'car tabs)))))
+ (let ((tabs (rst-line-tabs)))
(when tabs
- ;; Consider only lines indented less or same if not INNERMOST.
- (when (or (not leftmost)
- (< leftcol leftmost)
- (and (not innermost) (= leftcol leftmost)))
- (dolist (tab tabs)
- (let ((inner (cdr tab))
- (newcol (car tab)))
- (when (and
- (or
- (and (not inner)
- (or (not leftmost)
- (< newcol leftmost)))
- (and inner
- (or (not innermost)
- (< newcol innermost))))
- (not (memq newcol tablist)))
- (push newcol tablist))))
- (setq innermost (if (rst-some (mapcar 'cdr tabs)) ; Has inner.
- leftcol
- innermost))
- (setq leftmost leftcol)))))
+ (let ((leftcol (apply #'min (mapcar #'car tabs))))
+ ;; Consider only lines indented less or same if not INNERMOST.
+ (when (or (not leftmost)
+ (< leftcol leftmost)
+ (and (not innermost) (= leftcol leftmost)))
+ (rst-destructuring-dolist ((column &rest inner) tabs)
+ (when (or
+ (and (not inner)
+ (or (not leftmost)
+ (< column leftmost)))
+ (and inner
+ (or (not innermost)
+ (< column innermost))))
+ (setq tablist (cl-adjoin column tablist))))
+ (setq innermost (if (cl-some #'cdr tabs) ; Has inner.
+ leftcol
+ innermost))
+ (setq leftmost leftcol))))))
(nreverse tablist))))
(defun rst-indent-line (&optional dflt)
@@ -3291,7 +3323,7 @@ relative to the content."
(cur (current-indentation))
(clm (current-column))
(tabs (rst-compute-tabs (point)))
- (fnd (rst-position cur tabs))
+ (fnd (cl-position cur tabs :test #'equal))
ind)
(if (and (not tabs) (not dflt))
'noindent
@@ -3315,7 +3347,9 @@ Shift by one tab to the right (CNT > 0) or left (CNT < 0)
or
remove all indentation (CNT = 0). A tab is taken from the text
above. If no suitable tab is found `rst-indent-width' is used."
(interactive "r\np")
- (let ((tabs (sort (rst-compute-tabs beg) (lambda (x y) (<= x y))))
+ (let ((tabs (sort (rst-compute-tabs beg)
+ #'(lambda (x y)
+ (<= x y))))
(leftmostcol (rst-find-leftmost-column beg end)))
(when (or (> leftmostcol 0) (> cnt 0))
;; Apply the indent.
@@ -3324,17 +3358,15 @@ above. If no suitable tab is found `rst-indent-width'
is used."
(if (zerop cnt)
(- leftmostcol)
;; Find the next tab after the leftmost column.
- (let* ((cmp (if (> cnt 0) '> '<))
+ (let* ((cmp (if (> cnt 0) #'> #'<))
(tabs (if (> cnt 0) tabs (reverse tabs)))
(len (length tabs))
- (dir (rst-signum cnt)) ; Direction to take.
+ (dir (cl-signum cnt)) ; Direction to take.
(abs (abs cnt)) ; Absolute number of steps to take.
;; Get the position of the first tab beyond leftmostcol.
- (fnd (lexical-let ((cmp cmp)
- (leftmostcol leftmostcol)) ;; Create closure.
- (rst-position-if (lambda (elt)
- (funcall cmp elt leftmostcol))
- tabs)))
+ (fnd (cl-position-if #'(lambda (elt)
+ (funcall cmp elt leftmostcol))
+ tabs))
;; Virtual position of tab.
(pos (+ (or fnd len) (1- abs)))
(tab (if (< pos len)
@@ -3357,20 +3389,21 @@ above. If no suitable tab is found `rst-indent-width'
is used."
(defun rst-adaptive-fill ()
"Return fill prefix found at point.
Value for `adaptive-fill-function'."
- (let ((fnd (if (looking-at adaptive-fill-regexp)
- (match-string-no-properties 0))))
- (if (save-match-data
- (not (string-match comment-start-skip fnd)))
- ;; An non-comment prefix is fine.
- fnd
- ;; Matches a comment - return whitespace instead.
- (make-string (-
- (save-excursion
- (goto-char (match-end 0))
- (current-column))
- (save-excursion
- (goto-char (match-beginning 0))
- (current-column))) ? ))))
+ (save-match-data
+ (let ((fnd (if (looking-at adaptive-fill-regexp)
+ (match-string-no-properties 0))))
+ (if (save-match-data
+ (not (string-match comment-start-skip fnd)))
+ ;; An non-comment prefix is fine.
+ fnd
+ ;; Matches a comment - return whitespace instead.
+ (make-string (-
+ (save-excursion
+ (goto-char (match-end 0))
+ (current-column))
+ (save-excursion
+ (goto-char (match-beginning 0))
+ (current-column))) ? )))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Comments
@@ -3406,10 +3439,9 @@ Region is from BEG to END. Uncomment if ARG."
(if (consp arg)
(rst-uncomment-region beg end arg)
(goto-char beg)
+ (rst-forward-line-strict 0)
(let ((ind (current-indentation))
- bol)
- (forward-line 0)
- (setq bol (point))
+ (bol (point)))
(indent-rigidly bol end rst-indent-comment)
(goto-char bol)
(open-line 1)
@@ -3420,14 +3452,13 @@ Region is from BEG to END. Uncomment if ARG."
"Uncomment the current region.
Region is from BEG to END. _ARG is ignored"
(save-excursion
- (let (bol eol)
- (goto-char beg)
- (forward-line 0)
- (setq bol (point))
- (forward-line 1)
- (setq eol (point))
- (indent-rigidly eol end (- rst-indent-comment))
- (delete-region bol eol))))
+ (goto-char beg)
+ (rst-forward-line-strict 0)
+ (let ((bol (point)))
+ (rst-forward-line-strict 1 end)
+ (indent-rigidly (point) end (- rst-indent-comment))
+ (goto-char bol)
+ (rst-delete-entire-line 0))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Apply to indented block
@@ -3445,95 +3476,94 @@ containing or after BEG and indented to IND. After the
first
line the indented block may contain more lines with same
indentation (the paragraph) followed by empty lines and lines
more indented (the sub-blocks). A following line indented to IND
-starts the next indented block. A line with less indentation
-than IND terminates the current indented block. Such lines and
-all following lines not indented to IND are skipped. FUN is
-applied to unskipped lines like this
-
- (FUN COUNT FIRSTP SUBP EMPTYP RELIND LASTRET)
-
-COUNT is 0 before the first indented block and increments for
-every indented block found.
-
-FIRSTP is t when this is the first line of the paragraph.
-
-SUBP is t when this line is part of a sub-block.
-
-EMPTYP is t when this line is empty.
-
-RELIND is nil for an empty line, 0 for a line indented to IND,
-and the number of columns more indented otherwise.
-
-LASTRET is the return value of FUN returned by the last
-invocation for the same indented block or nil for the first
-invocation.
-
-When FUN is called point is immediately behind indentation of
-that line. FUN may change everything as long as a marker at END
-is handled correctly by the change.
-
-Return the return value of the last invocation of FUN or nil if
-FUN was never called."
- (let (lastret
- subp
- skipping
- nextm
- (count 0) ; Before first indented block
- (endm (copy-marker end t)))
- (save-excursion
- (goto-char beg)
- (while (< (point) endm)
- (save-excursion
- (setq nextm (save-excursion
- (forward-line 1)
- (copy-marker (point) t)))
+starts the next paragraph. A non-empty line with less
+indentation than IND terminates the current paragraph. FUN is
+applied to each line like this
+
+ (FUN COUNT IN-FIRST IN-SUB IN-SUPER IN-EMPTY RELIND)
+
+COUNT is 0 before the first paragraph and increments for every
+paragraph found on level IND. IN-FIRST is non-nil if this is the
+first line of such a paragraph. IN-SUB is non-nil if this line
+is part of a sub-block while IN-SUPER is non-nil of this line is
+part of a less indented block (super-block). IN-EMPTY is non-nil
+if this line is empty where an empty line is considered being
+part of the previous block. RELIND is nil for an empty line, 0
+for a line indented to IND, and the positive or negative number
+of columns more or less indented otherwise. When FUN is called
+point is immediately behind indentation of that line. FUN may
+change everything as long as a marker at END and at the beginning
+of the following line is handled correctly by the change. A
+non-nil return value from FUN breaks the loop and is returned.
+Otherwise return nil."
+ (let ((endm (copy-marker end t))
+ (count 0) ; Before first indented block.
+ (nxt (when (< beg end)
+ (copy-marker beg t)))
+ (broken t)
+ in-sub in-super stop)
+ (save-match-data
+ (save-excursion
+ (while (and (not stop) nxt)
+ (set-marker
+ (goto-char nxt) nil)
+ (setq nxt (save-excursion
+ ;; FIXME refactoring: Replace `(forward-line)
+ ;; (back-to-indentation)` by
+ ;; `(forward-to-indentation)`
+ (when (and (rst-forward-line-strict 1 endm)
+ (< (point) endm))
+ (copy-marker (point) t))))
(back-to-indentation)
- (let (firstp
- emptyp
- (relind (- (current-column) ind)))
+ (let ((relind (- (current-indentation) ind))
+ (in-empty (looking-at (rst-re 'lin-end)))
+ in-first)
(cond
- ((looking-at (rst-re 'lin-end))
- (setq emptyp t)
- (setq relind nil)
- ;; Breaks indented block if one is started
- (setq subp (not (zerop count))))
- ((< relind 0) ; Less indented
- (setq skipping t))
- ((zerop relind) ; In indented block
- (when (or subp skipping (zerop count))
- (setq firstp t)
- (incf count))
- (setq subp nil)
- (setq skipping nil))
- (t ; More indented
- (setq subp t)))
- (unless skipping
- (setq lastret
- (funcall fun count firstp subp emptyp relind lastret)))))
- (goto-char nextm))
- lastret)))
+ (in-empty
+ (setq relind nil))
+ ((< relind 0)
+ (setq in-sub nil)
+ (setq in-super t))
+ ((> relind 0)
+ (setq in-sub t)
+ (setq in-super nil))
+ (t ; Non-empty line in indented block.
+ (when (or broken in-sub in-super)
+ (setq in-first t)
+ (cl-incf count))
+ (setq in-sub nil)
+ (setq in-super nil)))
+ (save-excursion
+ (setq
+ stop
+ (funcall fun count in-first in-sub in-super in-empty relind)))
+ (setq broken in-empty)))
+ (set-marker endm nil)
+ stop))))
(defun rst-enumerate-region (beg end all)
"Add enumeration to all the leftmost paragraphs in the given region.
The region is specified between BEG and END. With ALL,
do all lines instead of just paragraphs."
(interactive "r\nP")
- (let ((enum 0))
+ (let ((enum 0)
+ (indent ""))
(rst-apply-indented-blocks
beg end (rst-find-leftmost-column beg end)
- (lambda (count firstp subp emptyp relind lastret)
- (cond
- (emptyp)
- ((zerop count))
- (subp
- (insert lastret))
- ((or firstp all)
- (let ((ins (format "%d. " (incf enum))))
- (setq lastret (make-string (length ins) ?\ ))
- (insert ins)))
- (t
- (insert lastret)))
- lastret))))
+ #'(lambda (count in-first in-sub in-super in-empty _relind)
+ (cond
+ (in-empty)
+ (in-super)
+ ((zerop count))
+ (in-sub
+ (insert indent))
+ ((or in-first all)
+ (let ((tag (format "%d. " (cl-incf enum))))
+ (setq indent (make-string (length tag) ? ))
+ (insert tag)))
+ (t
+ (insert indent)))
+ nil))))
;; FIXME: Does not deal with deeper indentation - although
;; `rst-apply-indented-blocks' could.
@@ -3544,21 +3574,22 @@ do all lines instead of just paragraphs."
(interactive "r\nP")
(unless rst-preferred-bullets
(error "No preferred bullets defined"))
- (let ((bul (format "%c " (car rst-preferred-bullets)))
- (cont " "))
+ (let* ((bul (format "%c " (car rst-preferred-bullets)))
+ (indent (make-string (length bul) ? )))
(rst-apply-indented-blocks
beg end (rst-find-leftmost-column beg end)
- (lambda (count firstp subp emptyp relind lastret)
- (cond
- (emptyp)
- ((zerop count))
- (subp
- (insert cont))
- ((or firstp all)
- (insert bul))
- (t
- (insert cont)))
- nil))))
+ #'(lambda (count in-first in-sub in-super in-empty _relind)
+ (cond
+ (in-empty)
+ (in-super)
+ ((zerop count))
+ (in-sub
+ (insert indent))
+ ((or in-first all)
+ (insert bul))
+ (t
+ (insert indent)))
+ nil))))
;; FIXME: Does not deal with a varying number of digits appropriately.
;; FIXME: Does not deal with multiple levels independently.
@@ -3567,19 +3598,19 @@ do all lines instead of just paragraphs."
"Convert the bulleted and enumerated items in the region to enumerated lists.
Renumber as necessary. Region is from BEG to END."
(interactive "r")
- (let* (;; Find items and convert the positions to markers.
- (items (mapcar
- (lambda (x)
- (cons (copy-marker (car x))
- (cdr x)))
- (rst-find-pfx-in-region beg end (rst-re 'itmany-sta-1))))
- (count 1))
- (save-excursion
- (dolist (x items)
- (goto-char (car x))
- (looking-at (rst-re 'itmany-beg-1))
- (replace-match (format "%d." count) nil nil nil 1)
- (incf count)))))
+ (let ((count 1))
+ (save-match-data
+ (save-excursion
+ (dolist (marker (mapcar
+ (cl-function
+ (lambda ((pnt &rest clm))
+ (copy-marker pnt)))
+ (rst-find-begs beg end 'itmany-beg-1)))
+ (set-marker
+ (goto-char marker) nil)
+ (looking-at (rst-re 'itmany-beg-1))
+ (replace-match (format "%d." count) nil nil nil 1)
+ (cl-incf count))))))
(defun rst-line-block-region (beg end &optional with-empty)
"Add line block prefixes for a region.
@@ -3588,10 +3619,11 @@ Region is from BEG to END. With WITH-EMPTY prefix
empty lines too."
(let ((ind (rst-find-leftmost-column beg end)))
(rst-apply-indented-blocks
beg end ind
- (lambda (count firstp subp emptyp relind lastret)
- (when (or with-empty (not emptyp))
- (move-to-column ind t)
- (insert "| "))))))
+ #'(lambda (_count _in-first _in-sub in-super in-empty _relind)
+ (when (and (not in-super) (or with-empty (not in-empty)))
+ (move-to-column ind t)
+ (insert "| "))
+ nil))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -4040,14 +4072,16 @@ Return nil if not or a cons with new values for BEG /
END"
(if (or nbeg nend)
(cons (or nbeg beg) (or nend end)))))
+;; FIXME refactoring: Use `rst-forward-line-strict' instead.
(defun rst-forward-line (&optional n)
"Like `forward-line' but always end up in column 0 and return accordingly.
Move N lines forward just as `forward-line'."
- (let ((moved (forward-line n)))
+ (let ((left (forward-line n)))
(if (bolp)
- moved
+ left
+ ;; FIXME: This may move back for positive n - is this desired?
(forward-line 0)
- (- moved (rst-signum n)))))
+ (- left (cl-signum n)))))
;; FIXME: If a single line is made a section header by `rst-adjust' the header
;; is not always fontified immediately.
@@ -4068,77 +4102,73 @@ Return extended point or nil if not moved."
;; The second group consists of the adornment cases.
(if (not (get-text-property pt 'font-lock-multiline))
;; Move only if we don't start inside a multiline construct already.
- (save-excursion
- (let (;; Non-empty non-indented line, explicit markup tag or literal
- ;; block tag.
- (stop-re (rst-re '(:alt "[^ \t\n]"
- (:seq hws-tag exm-tag)
- (:seq ".*" dcl-tag lin-end)))))
- ;; The comments below are for dir == -1 / dir == 1.
- (goto-char pt)
- (forward-line 0)
- (setq pt (point))
- (while (and (not (looking-at stop-re))
- (zerop (rst-forward-line dir)))) ; try previous / next
- ; line if it exists.
- (if (looking-at (rst-re 'ado-beg-2-1)) ; may be an underline /
- ; overline.
- (if (zerop (rst-forward-line dir))
- (if (looking-at (rst-re 'ttl-beg-1)) ; title found, i.e.
- ; underline / overline
- ; found.
- (if (zerop (rst-forward-line dir))
- (if (not
- (looking-at (rst-re 'ado-beg-2-1))) ; no
- ; overline /
- ; underline.
- (rst-forward-line (- dir)))) ; step back to title
- ; / adornment.
- (if (< dir 0) ; keep downward adornment.
- (rst-forward-line (- dir))))) ; step back to adornment.
- (if (looking-at (rst-re 'ttl-beg-1)) ; may be a title.
+ (save-match-data
+ (save-excursion
+ (let ( ; Non-empty non-indented line, explicit markup tag or literal
+ ; block tag.
+ (stop-re (rst-re '(:alt "[^ \t\n]"
+ (:seq hws-tag exm-tag)
+ (:seq ".*" dcl-tag lin-end)))))
+ ;; The comments below are for dir == -1 / dir == 1.
+ (goto-char pt)
+ (rst-forward-line-strict 0)
+ (setq pt (point))
+ (while (and (not (looking-at stop-re))
+ (zerop (rst-forward-line dir)))) ; try previous / next
+ ; line if it exists.
+ (if (looking-at (rst-re 'ado-beg-2-1)) ; may be an underline /
+ ; overline.
(if (zerop (rst-forward-line dir))
- (if (not
- (looking-at (rst-re 'ado-beg-2-1))) ; no overline /
- ; underline.
- (rst-forward-line (- dir)))))) ; step back to line.
- (if (not (= (point) pt))
- (point))))))
+ (if (looking-at (rst-re 'ttl-beg-1)) ; title found, i.e.
+ ; underline / overline
+ ; found.
+ (if (zerop (rst-forward-line dir))
+ (if (not
+ (looking-at (rst-re 'ado-beg-2-1))) ; no
+ ; overline
+ ; /
+ ;
underline.
+ (rst-forward-line (- dir)))) ; step back to
+ ; title /
+ ; adornment.
+ (if (< dir 0) ; keep downward adornment.
+ (rst-forward-line (- dir))))) ; step back to
adornment.
+ (if (looking-at (rst-re 'ttl-beg-1)) ; may be a title.
+ (if (zerop (rst-forward-line dir))
+ (if (not
+ (looking-at (rst-re 'ado-beg-2-1))) ; no overline /
+ ; underline.
+ (rst-forward-line (- dir)))))) ; step back to line.
+ (if (not (= (point) pt))
+ (point)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Indented blocks
(defun rst-forward-indented-block (&optional column limit)
+ ;; testcover: ok.
"Move forward across one indented block.
-Find the next non-empty line which is not indented at least to COLUMN (defaults
-to the column of the point). Moves point to first character of this line or
the
-first empty line immediately before it and returns that position. If there is
-no such line before LIMIT (defaults to the end of the buffer) returns nil and
-point is not moved."
- (interactive)
- (let ((clm (or column (current-column)))
- (start (point))
- fnd beg cand)
- (if (not limit)
- (setq limit (point-max)))
- (save-match-data
- (while (and (not fnd) (< (point) limit))
- (forward-line 1)
- (when (< (point) limit)
- (setq beg (point))
- (if (looking-at (rst-re 'lin-end))
- (setq cand (or cand beg)) ; An empty line is a candidate.
- (move-to-column clm)
- ;; FIXME: No indentation [(zerop clm)] must be handled in some
- ;; useful way - though it is not clear what this should mean
- ;; at all.
- (if (string-match
- (rst-re 'linemp-tag)
- (buffer-substring-no-properties beg (point)))
- (setq cand nil) ; An indented line resets a candidate.
- (setq fnd (or cand beg)))))))
- (goto-char (or fnd start))
- fnd))
+Find the next non-empty line which is not indented at least to
+COLUMN (defaults to the column of the point). Moves point to
+first character of this line or the first of the empty lines
+immediately before it and returns that position. If there is no
+such line before LIMIT (defaults to the end of the buffer)
+returns nil and point is not moved."
+ (let (fnd candidate)
+ (setq fnd (rst-apply-indented-blocks
+ (point) (or limit (point-max)) (or column (current-column))
+ #'(lambda (_count _in-first _in-sub in-super in-empty _relind)
+ (cond
+ (in-empty
+ (setq candidate (or candidate (line-beginning-position)))
+ nil)
+ (in-super
+ (or candidate (line-beginning-position)))
+ (t ; Non-empty, same or more indented line.
+ (setq candidate nil)
+ nil)))))
+ (when fnd
+ (goto-char fnd))))
(defvar rst-font-lock-find-unindented-line-begin nil
"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
next non-empty line if this is indented more than the current one."
(setq rst-font-lock-find-unindented-line-begin ind-pnt)
(setq rst-font-lock-find-unindented-line-end
- (save-excursion
- (when (not (numberp ind-pnt))
- ;; Find indentation point in next line if any.
- (setq ind-pnt
- ;; FIXME: Should be refactored to two different functions
- ;; giving their result to this function, may be
- ;; integrated in caller.
- (save-match-data
- (let ((cur-ind (current-indentation)))
- (if (eq ind-pnt 'next)
- (when (and (zerop (forward-line 1))
- (< (point) (point-max)))
- ;; Not at EOF.
- (setq rst-font-lock-find-unindented-line-begin
- (point))
- (when (and (not (looking-at (rst-re 'lin-end)))
- (> (current-indentation) cur-ind))
+ (save-match-data
+ (save-excursion
+ (when (not (numberp ind-pnt))
+ ;; Find indentation point in next line if any.
+ (setq ind-pnt
+ ;; FIXME: Should be refactored to two different functions
+ ;; giving their result to this function, may be
+ ;; integrated in caller.
+ (save-match-data
+ (let ((cur-ind (current-indentation)))
+ (if (eq ind-pnt 'next)
+ (when (and (rst-forward-line-strict 1 (point-max))
+ (< (point) (point-max)))
+ ;; Not at EOF.
+ (setq rst-font-lock-find-unindented-line-begin
+ (point))
+ (when (and (not (looking-at (rst-re 'lin-end)))
+ (> (current-indentation) cur-ind))
;; Use end of indentation if non-empty line.
(looking-at (rst-re 'hws-tag))
(match-end 0)))
- ;; Skip until non-empty line or EOF.
- (while (and (zerop (forward-line 1))
- (< (point) (point-max))
- (looking-at (rst-re 'lin-end))))
- (when (< (point) (point-max))
- ;; Not at EOF.
- (setq rst-font-lock-find-unindented-line-begin
- (point))
- (when (> (current-indentation) cur-ind)
- ;; Indentation bigger than line of departure.
- (looking-at (rst-re 'hws-tag))
- (match-end 0))))))))
- (when ind-pnt
- (goto-char ind-pnt)
- (or (rst-forward-indented-block nil (point-max))
- (point-max))))))
+ ;; Skip until non-empty line or EOF.
+ (while (and (rst-forward-line-strict 1 (point-max))
+ (< (point) (point-max))
+ (looking-at (rst-re 'lin-end))))
+ (when (< (point) (point-max))
+ ;; Not at EOF.
+ (setq rst-font-lock-find-unindented-line-begin
+ (point))
+ (when (> (current-indentation) cur-ind)
+ ;; Indentation bigger than line of departure.
+ (looking-at (rst-re 'hws-tag))
+ (match-end 0))))))))
+ (when ind-pnt
+ (goto-char ind-pnt)
+ (or (rst-forward-indented-block nil (point-max))
+ (point-max)))))))
(defun rst-font-lock-find-unindented-line-match (_limit)
"Set the match found earlier if match were found.
@@ -4359,33 +4390,31 @@ select the alternative tool-set."
(interactive "P")
;; Note: maybe we want to check if there is a Makefile too and not do
anything
;; if that is the case. I dunno.
- (let* ((toolset (cdr (assq (if use-alt
- rst-compile-secondary-toolset
- rst-compile-primary-toolset)
- rst-compile-toolsets)))
- (command (car toolset))
- (extension (cadr toolset))
- (options (caddr toolset))
- (conffile (rst-compile-find-conf))
- (bufname (file-name-nondirectory buffer-file-name))
- (outname (file-name-sans-extension bufname)))
-
+ (cl-destructuring-bind
+ (command extension options
+ &aux (conffile (rst-compile-find-conf))
+ (bufname (file-name-nondirectory buffer-file-name)))
+ (cdr (assq (if use-alt
+ rst-compile-secondary-toolset
+ rst-compile-primary-toolset)
+ rst-compile-toolsets))
;; Set compile-command before invocation of compile.
(setq-local
compile-command
- (mapconcat 'identity
- (list command
- (or options "")
- (if conffile
- (concat "--config=" (shell-quote-argument conffile))
- "")
- (shell-quote-argument bufname)
- (shell-quote-argument (concat outname extension)))
- " "))
-
+ (mapconcat
+ #'identity
+ (list command
+ (or options "")
+ (if conffile
+ (concat "--config=" (shell-quote-argument conffile))
+ "")
+ (shell-quote-argument bufname)
+ (shell-quote-argument (concat (file-name-sans-extension bufname)
+ extension)))
+ " "))
;; Invoke the compile command.
(if (or compilation-read-command use-alt)
- (call-interactively 'compile)
+ (call-interactively #'compile)
(compile compile-command))))
(defun rst-compile-alt-toolset ()
@@ -4443,6 +4472,10 @@ buffer, if the region is not selected."
;; FIXME: Add `rst-compile-html-preview'.
+;; FIXME: Add support for `restview` (http://mg.pov.lt/restview/). May be a
+;; more general facility for calling commands on a reST file would make
+;; sense.
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Imenu support
@@ -4470,12 +4503,12 @@ buffer, if the region is not selected."
;; become visible even for long title lines. May be an additional
;; level number is also useful.
(setq name (format "%s%s%s" pfx txt sfx))
- (cons name ;; The name of the entry.
+ (cons name ; The name of the entry.
(if children
- (cons ;; The entry has a submenu.
- (cons name pos) ;; The entry itself.
- (mapcar 'rst-imenu-convert-cell children)) ;; The children.
- pos)))) ;; The position of a plain entry.
+ (cons ; The entry has a submenu.
+ (cons name pos) ; The entry itself.
+ (mapcar #'rst-imenu-convert-cell children)) ; The children.
+ pos)))) ; The position of a plain entry.
;; FIXME: Document title and subtitle need to be handled properly. They should
;; get an own "Document" top level entry.
@@ -4485,7 +4518,7 @@ Return as described for `imenu--index-alist'."
(rst-reset-section-caches)
(let ((root (rst-all-stn)))
(when root
- (mapcar 'rst-imenu-convert-cell (rst-Stn-children root)))))
+ (mapcar #'rst-imenu-convert-cell (rst-Stn-children root)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -4504,7 +4537,7 @@ cand replace with char: ")
(setq found (1+ found))
(goto-char (match-beginning 1))
(let ((width (current-column)))
- (rst-delete-entire-line)
+ (rst-delete-entire-line 0)
(insert-char tochar width)))
(message "%d lines replaced." found))))
@@ -4513,7 +4546,7 @@ cand replace with char: ")
"Join lines in current paragraph into one line, removing end-of-lines."
(interactive)
(let ((fill-column 65000)) ; Some big number.
- (call-interactively 'fill-paragraph)))
+ (call-interactively #'fill-paragraph)))
;; FIXME: Unbound command - should be bound or removed.
(defun rst-force-fill-paragraph ()
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] master 9ed3685: Lots of refactorings and a few minor improvements.,
Stefan Merten <=