1 ;;; rng-maint.el --- commands for RELAX NG maintainers
3 ;; Copyright (C) 2003, 2007, 2008 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
52 (let ((standard-output texi-buf
))
53 (princ (format "\\input texinfo @c -*- texinfo -*-\n\
54 @c %%**start of header\n\
57 @c %%**end of header\n" rng-manual-info
))
59 (goto-char (point-min))
61 (xmltok-forward-prolog)
66 (texinfo-insert-node-lines (point-min) (point-max) t
)
67 (texinfo-all-menus-update)
70 (defun rng-manual-fixup ()
71 (goto-char (point-min))
72 (search-forward "@top ")
75 (let ((title (buffer-substring-no-properties pos
(1- (point)))))
76 (goto-char (point-min))
77 (search-forward "@settitle ")
79 (search-forward "@node")
80 (goto-char (match-beginning 0))
81 (insert "@dircategory Emacs\n"
86 ").\n@end direntry\n\n"))))
88 (defvar rng-manual-inline-elements
'(kbd key samp code var emph uref point
))
90 (defun rng-process-tokens ()
91 (let ((section-depth 0)
92 ;; stack of per-element space treatment
93 ;; t means keep, nil means discard, fill means no blank lines
94 (keep-space-stack (list nil
))
95 (ignore-following-newline nil
)
97 name startp endp data keep-space-for-children
)
98 (while (xmltok-forward)
99 (cond ((memq xmltok-type
'(start-tag empty-element end-tag
))
100 (setq startp
(memq xmltok-type
'(start-tag empty-element
)))
101 (setq endp
(memq xmltok-type
'(end-tag empty-element
)))
102 (setq name
(intern (if startp
103 (xmltok-start-tag-qname)
104 (xmltok-end-tag-qname))))
105 (setq keep-space-for-children nil
)
106 (setq ignore-following-newline nil
)
107 (cond ((memq name rng-manual-inline-elements
)
109 (when want-blank-line
110 (rng-manual-output-force-blank-line)
111 (when (eq want-blank-line
'noindent
)
112 (princ "@noindent\n"))
113 (setq want-blank-line nil
))
114 (setq keep-space-for-children t
)
115 (princ (format "@%s{" name
)))
116 (when endp
(princ "}")))
119 (rng-manual-output-force-blank-line)
120 (setq want-blank-line nil
)
121 (princ "@itemize @bullet\n"))
123 (rng-manual-output-force-new-line)
124 (setq want-blank-line
'noindent
)
125 (princ "@end itemize\n")))
127 (rng-manual-output-force-new-line)
128 (setq want-blank-line endp
)
129 (when startp
(princ "@item\n")))
130 ((memq name
'(example display
))
132 (setq ignore-following-newline t
)
133 (rng-manual-output-force-blank-line)
134 (setq want-blank-line nil
)
135 (setq keep-space-for-children t
)
136 (princ (format "@%s\n" name
)))
138 (rng-manual-output-force-new-line)
139 (setq want-blank-line
'noindent
)
140 (princ (format "@end %s\n" name
))))
142 (rng-manual-output-force-new-line)
144 (when want-blank-line
145 (setq want-blank-line t
))
146 (setq keep-space-for-children
'fill
))
147 (when endp
(setq want-blank-line t
)))
150 (rng-manual-output-force-blank-line)
151 (when (eq section-depth
0)
152 (princ "@node Top\n"))
154 (princ (nth section-depth
'(top
160 (setq want-blank-line nil
)
161 (setq section-depth
(1+ section-depth
)))
163 (rng-manual-output-force-new-line)
164 (setq want-blank-line nil
)
165 (setq section-depth
(1- section-depth
))))
168 (setq keep-space-for-children
'fill
))
170 (setq want-blank-line t
)
173 (setq keep-space-stack
(cons keep-space-for-children
176 (setq keep-space-stack
(cdr keep-space-stack
))))
177 ((memq xmltok-type
'(data
183 (cond ((memq xmltok-type
'(data space
))
184 (setq data
(buffer-substring-no-properties xmltok-start
186 ((and (memq xmltok-type
'(char-ref entity-ref
))
188 (setq data xmltok-replacement
))
189 ((eq xmltok-type
'cdata-section
)
191 (buffer-substring-no-properties (+ xmltok-start
9)
193 (when (and data
(car keep-space-stack
))
194 (setq data
(replace-regexp-in-string "[@{}]"
198 (when ignore-following-newline
199 (setq data
(replace-regexp-in-string "\\`\n" "" data t
)))
200 (setq ignore-following-newline nil
)
201 ;; (when (eq (car keep-space-stack) 'fill)
202 ;; (setq data (replace-regexp-in-string "\n" " " data t)))
203 (when (eq want-blank-line
'noindent
)
204 (setq data
(replace-regexp-in-string "\\`\n*" "" data t
)))
205 (when (> (length data
) 0)
206 (when want-blank-line
207 (rng-manual-output-force-blank-line)
208 (when (eq want-blank-line
'noindent
)
209 (princ "@noindent\n"))
210 (setq want-blank-line nil
))
214 (defun rng-manual-output-force-new-line ()
216 (set-buffer standard-output
)
217 (unless (eq (char-before) ?
\n)
220 (defun rng-manual-output-force-blank-line ()
222 (set-buffer standard-output
)
223 (if (eq (char-before) ?
\n)
224 (unless (eq (char-before (1- (point))) ?
\n)
230 (defun rng-time-to-float (time)
231 (+ (* (nth 0 time
) 65536.0)
233 (/ (nth 2 time
) 1000000.0)))
235 (defun rng-time-function (function &rest args
)
236 (let* ((start (current-time))
237 (val (apply function args
))
238 (end (current-time)))
239 (message "%s ran in %g seconds"
241 (- (rng-time-to-float end
)
242 (rng-time-to-float start
)))
245 (defun rng-time-tokenize-buffer ()
247 (rng-time-function 'rng-tokenize-buffer
))
249 (defun rng-tokenize-buffer ()
251 (goto-char (point-min))
253 (xmltok-forward-prolog)
254 (while (xmltok-forward)))))
256 (defun rng-time-validate-buffer ()
258 (rng-time-function 'rng-validate-buffer
))
260 (defvar rng-error-count
)
261 (defvar rng-validate-up-to-date-end
)
262 (declare-function rng-clear-cached-state
"rng-valid" (start end
))
263 (declare-function rng-clear-overlays
"rng-valid" (beg end
))
264 (declare-function rng-clear-conditional-region
"rng-valid" ())
265 (declare-function rng-do-some-validation
"rng-valid"
266 (&optional continue-p-function
))
268 (defun rng-validate-buffer ()
271 (nxml-with-unmodifying-text-property-changes
272 (rng-clear-cached-state (point-min) (point-max)))
273 ;; 1+ to clear empty overlays at (point-max)
274 (rng-clear-overlays (point-min) (1+ (point-max))))
275 (setq rng-validate-up-to-date-end
1)
276 (rng-clear-conditional-region)
277 (setq rng-error-count
0)
278 (while (rng-do-some-validation
281 ;; arch-tag: 4b8c6143-daac-4888-9c61-9bea6f935f17
282 ;;; rng-maint.el ends here