lisp/nxml/rng-maint.el

   1 ;;; rng-maint.el --- commands for RELAX NG maintainers
   2
   3 ;; Copyright (C) 2003, 2007, 2008 Free Software Foundation, Inc.
   4
   5 ;; Author: James Clark
   6 ;; Keywords: XML, RelaxNG
   7
   8 ;; This file is part of GNU Emacs.
   9
  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, or (at your option)
  13 ;; any later version.
  14
  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.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24
  25 ;;; Commentary:
  26
  27 ;;; Code:
  28
  29 (require 'xmltok)
  30 (require 'nxml-mode)
  31 (require 'texnfo-upd)
  32
  33 (defvar rng-dir (file-name-directory load-file-name))
  34
  35 ;;; Conversion from XML to texinfo.
  36 ;; This is all a hack and is just enough to make the conversion work.
  37 ;; It's not intended for public use.
  38
  39 (defvar rng-manual-base "nxml-mode")
  40 (defvar rng-manual-xml (concat rng-manual-base ".xml"))
  41 (defvar rng-manual-texi (concat rng-manual-base ".texi"))
  42 (defvar rng-manual-info (concat rng-manual-base ".info"))
  43
  44 (defun rng-format-manual ()
  45   "Create manual.texi from manual.xml."
  46   (interactive)
  47   (let ((xml-buf (find-file-noselect (expand-file-name rng-manual-xml
  48                                                        rng-dir)))
  49         (texi-buf (find-file-noselect (expand-file-name rng-manual-texi
  50                                                         rng-dir))))
  51     (save-excursion
  52       (set-buffer texi-buf)
  53       (erase-buffer)
  54       (let ((standard-output texi-buf))
  55         (princ (format "\\input texinfo @c -*- texinfo -*-\n\
  56 @c %%**start of header\n\
  57 @setfilename %s\n\
  58 @settitle \n\
  59 @c %%**end of header\n" rng-manual-info))
  60         (set-buffer xml-buf)
  61         (goto-char (point-min))
  62         (xmltok-save
  63           (xmltok-forward-prolog)
  64           (rng-process-tokens))
  65         (princ "\n@bye\n"))
  66       (set-buffer texi-buf)
  67       (rng-manual-fixup)
  68       (texinfo-insert-node-lines (point-min) (point-max) t)
  69       (texinfo-all-menus-update)
  70       (save-buffer))))
  71
  72 (defun rng-manual-fixup ()
  73   (goto-char (point-min))
  74   (search-forward "@top ")
  75   (let ((pos (point)))
  76     (search-forward "\n")
  77     (let ((title (buffer-substring-no-properties pos (1- (point)))))
  78       (goto-char (point-min))
  79       (search-forward "@settitle ")
  80       (insert title)
  81       (search-forward "@node")
  82       (goto-char (match-beginning 0))
  83       (insert "@dircategory Emacs\n"
  84               "@direntry\n* "
  85               title
  86               ": ("
  87               rng-manual-info
  88               ").\n@end direntry\n\n"))))
  89
  90 (defvar rng-manual-inline-elements '(kbd key samp code var emph uref point))
  91
  92 (defun rng-process-tokens ()
  93   (let ((section-depth 0)
  94         ;; stack of per-element space treatment
  95         ;; t means keep, nil means discard, fill means no blank lines
  96         (keep-space-stack (list nil))
  97         (ignore-following-newline nil)
  98         (want-blank-line nil)
  99         name startp endp data keep-space-for-children)
 100     (while (xmltok-forward)
 101       (cond ((memq xmltok-type '(start-tag empty-element end-tag))
 102              (setq startp (memq xmltok-type '(start-tag empty-element)))
 103              (setq endp (memq xmltok-type '(end-tag empty-element)))
 104              (setq name (intern (if startp
 105                                     (xmltok-start-tag-qname)
 106                                   (xmltok-end-tag-qname))))
 107              (setq keep-space-for-children nil)
 108              (setq ignore-following-newline nil)
 109              (cond ((memq name rng-manual-inline-elements)
 110                     (when startp
 111                       (when want-blank-line
 112                         (rng-manual-output-force-blank-line)
 113                         (when (eq want-blank-line 'noindent)
 114                           (princ "@noindent\n"))
 115                         (setq want-blank-line nil))
 116                       (setq keep-space-for-children t)
 117                       (princ (format "@%s{" name)))
 118                     (when endp (princ "}")))
 119                    ((eq name 'ulist)
 120                     (when startp
 121                       (rng-manual-output-force-blank-line)
 122                       (setq want-blank-line nil)
 123                       (princ "@itemize @bullet\n"))
 124                     (when endp
 125                       (rng-manual-output-force-new-line)
 126                       (setq want-blank-line 'noindent)
 127                       (princ "@end itemize\n")))
 128                    ((eq name 'item)
 129                     (rng-manual-output-force-new-line)
 130                     (setq want-blank-line endp)
 131                     (when startp (princ "@item\n")))
 132                    ((memq name '(example display))
 133                     (when startp
 134                       (setq ignore-following-newline t)
 135                       (rng-manual-output-force-blank-line)
 136                       (setq want-blank-line nil)
 137                       (setq keep-space-for-children t)
 138                       (princ (format "@%s\n" name)))
 139                     (when endp
 140                       (rng-manual-output-force-new-line)
 141                       (setq want-blank-line 'noindent)
 142                       (princ (format "@end %s\n" name))))
 143                    ((eq name 'para)
 144                     (rng-manual-output-force-new-line)
 145                     (when startp
 146                       (when want-blank-line
 147                         (setq want-blank-line t))
 148                       (setq keep-space-for-children 'fill))
 149                     (when endp (setq want-blank-line t)))
 150                    ((eq name 'section)
 151                     (when startp
 152                       (rng-manual-output-force-blank-line)
 153                       (when (eq section-depth 0)
 154                         (princ "@node Top\n"))
 155                       (princ "@")
 156                       (princ (nth section-depth '(top
 157                                                   chapter
 158                                                   section
 159                                                   subsection
 160                                                   subsubsection)))
 161                       (princ " ")
 162                       (setq want-blank-line nil)
 163                       (setq section-depth (1+ section-depth)))
 164                     (when endp
 165                       (rng-manual-output-force-new-line)
 166                       (setq want-blank-line nil)
 167                       (setq section-depth (1- section-depth))))
 168                    ((eq name 'title)
 169                     (when startp
 170                       (setq keep-space-for-children 'fill))
 171                     (when endp
 172                       (setq want-blank-line t)
 173                       (princ "\n"))))
 174              (when startp
 175                (setq keep-space-stack (cons keep-space-for-children
 176                                             keep-space-stack)))
 177              (when endp
 178                (setq keep-space-stack (cdr keep-space-stack))))
 179             ((memq xmltok-type '(data
 180                                  space
 181                                  char-ref
 182                                  entity-ref
 183                                  cdata-section))
 184              (setq data nil)
 185              (cond ((memq xmltok-type '(data space))
 186                     (setq data (buffer-substring-no-properties xmltok-start
 187                                                                (point))))
 188                    ((and (memq xmltok-type '(char-ref entity-ref))
 189                          xmltok-replacement)
 190                     (setq data xmltok-replacement))
 191                    ((eq xmltok-type 'cdata-section)
 192                     (setq data
 193                           (buffer-substring-no-properties (+ xmltok-start 9)
 194                                                           (- (point) 3)))))
 195              (when (and data (car keep-space-stack))
 196                (setq data (replace-regexp-in-string "[@{}]"
 197                                                     "@\\&"
 198                                                     data
 199                                                     t))
 200                (when ignore-following-newline
 201                  (setq data (replace-regexp-in-string "\\`\n" "" data t)))
 202                (setq ignore-following-newline nil)
 203 ;;             (when (eq (car keep-space-stack) 'fill)
 204 ;;               (setq data (replace-regexp-in-string "\n" " " data t)))
 205                (when (eq want-blank-line 'noindent)
 206                  (setq data (replace-regexp-in-string "\\`\n*" "" data t)))
 207                (when (> (length data) 0)
 208                  (when want-blank-line
 209                    (rng-manual-output-force-blank-line)
 210                    (when (eq want-blank-line 'noindent)
 211                      (princ "@noindent\n"))
 212                    (setq want-blank-line nil))
 213                  (princ data))))
 214              ))))
 215
 216 (defun rng-manual-output-force-new-line ()
 217   (save-excursion
 218     (set-buffer standard-output)
 219     (unless (eq (char-before) ?\n)
 220       (insert ?\n))))
 221
 222 (defun rng-manual-output-force-blank-line ()
 223   (save-excursion
 224     (set-buffer standard-output)
 225     (if (eq (char-before) ?\n)
 226         (unless (eq (char-before (1- (point))) ?\n)
 227           (insert ?\n))
 228       (insert "\n\n"))))
 229
 230 ;;; Timing
 231
 232 (defun rng-time-to-float (time)
 233   (+ (* (nth 0 time) 65536.0)
 234      (nth 1 time)
 235      (/ (nth 2 time) 1000000.0)))
 236
 237 (defun rng-time-function (function &rest args)
 238   (let* ((start (current-time))
 239          (val (apply function args))
 240          (end (current-time)))
 241     (message "%s ran in %g seconds"
 242              function
 243              (- (rng-time-to-float end)
 244                 (rng-time-to-float start)))
 245     val))
 246
 247 (defun rng-time-tokenize-buffer ()
 248   (interactive)
 249   (rng-time-function 'rng-tokenize-buffer))
 250
 251 (defun rng-tokenize-buffer ()
 252   (save-excursion
 253     (goto-char (point-min))
 254     (xmltok-save
 255       (xmltok-forward-prolog)
 256       (while (xmltok-forward)))))
 257
 258 (defun rng-time-validate-buffer ()
 259   (interactive)
 260   (rng-time-function 'rng-validate-buffer))
 261
 262 (defvar rng-error-count)
 263 (defvar rng-validate-up-to-date-end)
 264 (declare-function rng-clear-cached-state "rng-valid" (start end))
 265 (declare-function rng-clear-overlays "rng-valid" (beg end))
 266 (declare-function rng-clear-conditional-region "rng-valid" ())
 267 (declare-function rng-do-some-validation "rng-valid"
 268                   (&optional continue-p-function))
 269
 270 (defun rng-validate-buffer ()
 271   (save-restriction
 272     (widen)
 273     (nxml-with-unmodifying-text-property-changes
 274       (rng-clear-cached-state (point-min) (point-max)))
 275     ;; 1+ to clear empty overlays at (point-max)
 276     (rng-clear-overlays (point-min) (1+ (point-max))))
 277   (setq rng-validate-up-to-date-end 1)
 278   (rng-clear-conditional-region)
 279   (setq rng-error-count 0)
 280   (while (rng-do-some-validation
 281           (lambda () t))))
 282
 283 ;; arch-tag: 4b8c6143-daac-4888-9c61-9bea6f935f17
 284 ;;; rng-maint.el ends here