lisp/nxml/rng-maint.el

   1 ;;; rng-maint.el --- commands for RELAX NG maintainers
   2
   3 ;; Copyright (C) 2003, 2007, 2008, 2009, 2010 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 of the License, or
  13 ;; (at your option) 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.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;;; Code:
  26
  27 (require 'xmltok)
  28 (require 'nxml-mode)
  29 (require 'texnfo-upd)
  30
  31 (defvar rng-dir (file-name-directory load-file-name))
  32
  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.
  36
  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"))
  41
  42 (defun rng-format-manual ()
  43   "Create manual.texi from manual.xml."
  44   (interactive)
  45   (let ((xml-buf (find-file-noselect (expand-file-name rng-manual-xml
  46                                                        rng-dir)))
  47         (texi-buf (find-file-noselect (expand-file-name rng-manual-texi
  48                                                         rng-dir))))
  49     (with-current-buffer texi-buf
  50       (erase-buffer)
  51       (let ((standard-output texi-buf))
  52         (princ (format "\\input texinfo @c -*- texinfo -*-\n\
  53 @c %%**start of header\n\
  54 @setfilename %s\n\
  55 @settitle \n\
  56 @c %%**end of header\n" rng-manual-info))
  57         (set-buffer xml-buf)
  58         (goto-char (point-min))
  59         (xmltok-save
  60           (xmltok-forward-prolog)
  61           (rng-process-tokens))
  62         (princ "\n@bye\n"))
  63       (set-buffer texi-buf)
  64       (rng-manual-fixup)
  65       (texinfo-insert-node-lines (point-min) (point-max) t)
  66       (texinfo-all-menus-update)
  67       (save-buffer))))
  68
  69 (defun rng-manual-fixup ()
  70   (goto-char (point-min))
  71   (search-forward "@top ")
  72   (let ((pos (point)))
  73     (search-forward "\n")
  74     (let ((title (buffer-substring-no-properties pos (1- (point)))))
  75       (goto-char (point-min))
  76       (search-forward "@settitle ")
  77       (insert title)
  78       (search-forward "@node")
  79       (goto-char (match-beginning 0))
  80       (insert "@dircategory Emacs\n"
  81               "@direntry\n* "
  82               title
  83               ": ("
  84               rng-manual-info
  85               ").\n@end direntry\n\n"))))
  86
  87 (defvar rng-manual-inline-elements '(kbd key samp code var emph uref point))
  88
  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)
  95         (want-blank-line 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)
 107                     (when startp
 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 "}")))
 116                    ((eq name 'ulist)
 117                     (when startp
 118                       (rng-manual-output-force-blank-line)
 119                       (setq want-blank-line nil)
 120                       (princ "@itemize @bullet\n"))
 121                     (when endp
 122                       (rng-manual-output-force-new-line)
 123                       (setq want-blank-line 'noindent)
 124                       (princ "@end itemize\n")))
 125                    ((eq name 'item)
 126                     (rng-manual-output-force-new-line)
 127                     (setq want-blank-line endp)
 128                     (when startp (princ "@item\n")))
 129                    ((memq name '(example display))
 130                     (when startp
 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)))
 136                     (when endp
 137                       (rng-manual-output-force-new-line)
 138                       (setq want-blank-line 'noindent)
 139                       (princ (format "@end %s\n" name))))
 140                    ((eq name 'para)
 141                     (rng-manual-output-force-new-line)
 142                     (when startp
 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)))
 147                    ((eq name 'section)
 148                     (when startp
 149                       (rng-manual-output-force-blank-line)
 150                       (when (eq section-depth 0)
 151                         (princ "@node Top\n"))
 152                       (princ "@")
 153                       (princ (nth section-depth '(top
 154                                                   chapter
 155                                                   section
 156                                                   subsection
 157                                                   subsubsection)))
 158                       (princ " ")
 159                       (setq want-blank-line nil)
 160                       (setq section-depth (1+ section-depth)))
 161                     (when endp
 162                       (rng-manual-output-force-new-line)
 163                       (setq want-blank-line nil)
 164                       (setq section-depth (1- section-depth))))
 165                    ((eq name 'title)
 166                     (when startp
 167                       (setq keep-space-for-children 'fill))
 168                     (when endp
 169                       (setq want-blank-line t)
 170                       (princ "\n"))))
 171              (when startp
 172                (setq keep-space-stack (cons keep-space-for-children
 173                                             keep-space-stack)))
 174              (when endp
 175                (setq keep-space-stack (cdr keep-space-stack))))
 176             ((memq xmltok-type '(data
 177                                  space
 178                                  char-ref
 179                                  entity-ref
 180                                  cdata-section))
 181              (setq data nil)
 182              (cond ((memq xmltok-type '(data space))
 183                     (setq data (buffer-substring-no-properties xmltok-start
 184                                                                (point))))
 185                    ((and (memq xmltok-type '(char-ref entity-ref))
 186                          xmltok-replacement)
 187                     (setq data xmltok-replacement))
 188                    ((eq xmltok-type 'cdata-section)
 189                     (setq data
 190                           (buffer-substring-no-properties (+ xmltok-start 9)
 191                                                           (- (point) 3)))))
 192              (when (and data (car keep-space-stack))
 193                (setq data (replace-regexp-in-string "[@{}]"
 194                                                     "@\\&"
 195                                                     data
 196                                                     t))
 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))
 210                  (princ data))))
 211              ))))
 212
 213 (defun rng-manual-output-force-new-line ()
 214   (with-current-buffer standard-output
 215     (unless (eq (char-before) ?\n)
 216       (insert ?\n))))
 217
 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)
 222           (insert ?\n))
 223       (insert "\n\n"))))
 224
 225 ;;; Timing
 226
 227 (defun rng-time-to-float (time)
 228   (+ (* (nth 0 time) 65536.0)
 229      (nth 1 time)
 230      (/ (nth 2 time) 1000000.0)))
 231
 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"
 237              function
 238              (- (rng-time-to-float end)
 239                 (rng-time-to-float start)))
 240     val))
 241
 242 (defun rng-time-tokenize-buffer ()
 243   (interactive)
 244   (rng-time-function 'rng-tokenize-buffer))
 245
 246 (defun rng-tokenize-buffer ()
 247   (save-excursion
 248     (goto-char (point-min))
 249     (xmltok-save
 250       (xmltok-forward-prolog)
 251       (while (xmltok-forward)))))
 252
 253 (defun rng-time-validate-buffer ()
 254   (interactive)
 255   (rng-time-function 'rng-validate-buffer))
 256
 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))
 264
 265 (defun rng-validate-buffer ()
 266   (save-restriction
 267     (widen)
 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
 276           (lambda () t))))
 277
 278 ;; arch-tag: 4b8c6143-daac-4888-9c61-9bea6f935f17
 279 ;;; rng-maint.el ends here