1 ;;; rng-maint.el --- commands for RELAX NG maintainers
3 ;; Copyright (C) 2003, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
6 ;; Keywords: XML, RelaxNG
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
31 (defvar rng-dir (file-name-directory load-file-name))
33 ;;; Conversion from XML to texinfo.
34 ;; This is all a hack and is just enough to make the conversion work.
35 ;; It's not intended for public use.
37 (defvar rng-manual-base "nxml-mode")
38 (defvar rng-manual-xml (concat rng-manual-base ".xml"))
39 (defvar rng-manual-texi (concat rng-manual-base ".texi"))
40 (defvar rng-manual-info (concat rng-manual-base ".info"))
42 (defun rng-format-manual ()
43 "Create manual.texi from manual.xml."
45 (let ((xml-buf (find-file-noselect (expand-file-name rng-manual-xml
47 (texi-buf (find-file-noselect (expand-file-name rng-manual-texi
49 (with-current-buffer texi-buf
51 (let ((standard-output texi-buf))
52 (princ (format "\\input texinfo @c -*- texinfo -*-\n\
53 @c %%**start of header\n\
56 @c %%**end of header\n" rng-manual-info))
58 (goto-char (point-min))
60 (xmltok-forward-prolog)
65 (texinfo-insert-node-lines (point-min) (point-max) t)
66 (texinfo-all-menus-update)
69 (defun rng-manual-fixup ()
70 (goto-char (point-min))
71 (search-forward "@top ")
74 (let ((title (buffer-substring-no-properties pos (1- (point)))))
75 (goto-char (point-min))
76 (search-forward "@settitle ")
78 (search-forward "@node")
79 (goto-char (match-beginning 0))
80 (insert "@dircategory Emacs\n"
85 ").\n@end direntry\n\n"))))
87 (defvar rng-manual-inline-elements '(kbd key samp code var emph uref point))
89 (defun rng-process-tokens ()
90 (let ((section-depth 0)
91 ;; stack of per-element space treatment
92 ;; t means keep, nil means discard, fill means no blank lines
93 (keep-space-stack (list nil))
94 (ignore-following-newline nil)
96 name startp endp data keep-space-for-children)
97 (while (xmltok-forward)
98 (cond ((memq xmltok-type '(start-tag empty-element end-tag))
99 (setq startp (memq xmltok-type '(start-tag empty-element)))
100 (setq endp (memq xmltok-type '(end-tag empty-element)))
101 (setq name (intern (if startp
102 (xmltok-start-tag-qname)
103 (xmltok-end-tag-qname))))
104 (setq keep-space-for-children nil)
105 (setq ignore-following-newline nil)
106 (cond ((memq name rng-manual-inline-elements)
108 (when want-blank-line
109 (rng-manual-output-force-blank-line)
110 (when (eq want-blank-line 'noindent)
111 (princ "@noindent\n"))
112 (setq want-blank-line nil))
113 (setq keep-space-for-children t)
114 (princ (format "@%s{" name)))
115 (when endp (princ "}")))
118 (rng-manual-output-force-blank-line)
119 (setq want-blank-line nil)
120 (princ "@itemize @bullet\n"))
122 (rng-manual-output-force-new-line)
123 (setq want-blank-line 'noindent)
124 (princ "@end itemize\n")))
126 (rng-manual-output-force-new-line)
127 (setq want-blank-line endp)
128 (when startp (princ "@item\n")))
129 ((memq name '(example display))
131 (setq ignore-following-newline t)
132 (rng-manual-output-force-blank-line)
133 (setq want-blank-line nil)
134 (setq keep-space-for-children t)
135 (princ (format "@%s\n" name)))
137 (rng-manual-output-force-new-line)
138 (setq want-blank-line 'noindent)
139 (princ (format "@end %s\n" name))))
141 (rng-manual-output-force-new-line)
143 (when want-blank-line
144 (setq want-blank-line t))
145 (setq keep-space-for-children 'fill))
146 (when endp (setq want-blank-line t)))
149 (rng-manual-output-force-blank-line)
150 (when (eq section-depth 0)
151 (princ "@node Top\n"))
153 (princ (nth section-depth '(top
159 (setq want-blank-line nil)
160 (setq section-depth (1+ section-depth)))
162 (rng-manual-output-force-new-line)
163 (setq want-blank-line nil)
164 (setq section-depth (1- section-depth))))
167 (setq keep-space-for-children 'fill))
169 (setq want-blank-line t)
172 (setq keep-space-stack (cons keep-space-for-children
175 (setq keep-space-stack (cdr keep-space-stack))))
176 ((memq xmltok-type '(data
182 (cond ((memq xmltok-type '(data space))
183 (setq data (buffer-substring-no-properties xmltok-start
185 ((and (memq xmltok-type '(char-ref entity-ref))
187 (setq data xmltok-replacement))
188 ((eq xmltok-type 'cdata-section)
190 (buffer-substring-no-properties (+ xmltok-start 9)
192 (when (and data (car keep-space-stack))
193 (setq data (replace-regexp-in-string "[@{}]"
197 (when ignore-following-newline
198 (setq data (replace-regexp-in-string "\\`\n" "" data t)))
199 (setq ignore-following-newline nil)
200 ;; (when (eq (car keep-space-stack) 'fill)
201 ;; (setq data (replace-regexp-in-string "\n" " " data t)))
202 (when (eq want-blank-line 'noindent)
203 (setq data (replace-regexp-in-string "\\`\n*" "" data t)))
204 (when (> (length data) 0)
205 (when want-blank-line
206 (rng-manual-output-force-blank-line)
207 (when (eq want-blank-line 'noindent)
208 (princ "@noindent\n"))
209 (setq want-blank-line nil))
213 (defun rng-manual-output-force-new-line ()
214 (with-current-buffer standard-output
215 (unless (eq (char-before) ?\n)
218 (defun rng-manual-output-force-blank-line ()
219 (with-current-buffer standard-output
220 (if (eq (char-before) ?\n)
221 (unless (eq (char-before (1- (point))) ?\n)
227 (defun rng-time-to-float (time)
228 (+ (* (nth 0 time) 65536.0)
230 (/ (nth 2 time) 1000000.0)))
232 (defun rng-time-function (function &rest args)
233 (let* ((start (current-time))
234 (val (apply function args))
235 (end (current-time)))
236 (message "%s ran in %g seconds"
238 (- (rng-time-to-float end)
239 (rng-time-to-float start)))
242 (defun rng-time-tokenize-buffer ()
244 (rng-time-function 'rng-tokenize-buffer))
246 (defun rng-tokenize-buffer ()
248 (goto-char (point-min))
250 (xmltok-forward-prolog)
251 (while (xmltok-forward)))))
253 (defun rng-time-validate-buffer ()
255 (rng-time-function 'rng-validate-buffer))
257 (defvar rng-error-count)
258 (defvar rng-validate-up-to-date-end)
259 (declare-function rng-clear-cached-state "rng-valid" (start end))
260 (declare-function rng-clear-overlays "rng-valid" (beg end))
261 (declare-function rng-clear-conditional-region "rng-valid" ())
262 (declare-function rng-do-some-validation "rng-valid"
263 (&optional continue-p-function))
265 (defun rng-validate-buffer ()
268 (nxml-with-unmodifying-text-property-changes
269 (rng-clear-cached-state (point-min) (point-max)))
270 ;; 1+ to clear empty overlays at (point-max)
271 (rng-clear-overlays (point-min) (1+ (point-max))))
272 (setq rng-validate-up-to-date-end 1)
273 (rng-clear-conditional-region)
274 (setq rng-error-count 0)
275 (while (rng-do-some-validation
278 ;; arch-tag: 4b8c6143-daac-4888-9c61-9bea6f935f17
279 ;;; rng-maint.el ends here