lisp/nxml/rng-maint.el

   1 ;;; rng-maint.el --- commands for RELAX NG maintainers
   2
   3 ;; Copyright (C) 2003, 2007, 2008, 2009 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     (save-excursion
  50       (set-buffer texi-buf)
  51       (erase-buffer)
  52       (let ((standard-output texi-buf))
  53         (princ (format "\\input texinfo @c -*- texinfo -*-\n\
  54 @c %%**start of header\n\
  55 @setfilename %s\n\
  56 @settitle \n\
  57 @c %%**end of header\n" rng-manual-info))
  58         (set-buffer xml-buf)
  59         (goto-char (point-min))
  60         (xmltok-save
  61           (xmltok-forward-prolog)
  62           (rng-process-tokens))
  63         (princ "\n@bye\n"))
  64       (set-buffer texi-buf)
  65       (rng-manual-fixup)
  66       (texinfo-insert-node-lines (point-min) (point-max) t)
  67       (texinfo-all-menus-update)
  68       (save-buffer))))
  69
  70 (defun rng-manual-fixup ()
  71   (goto-char (point-min))
  72   (search-forward "@top ")
  73   (let ((pos (point)))
  74     (search-forward "\n")
  75     (let ((title (buffer-substring-no-properties pos (1- (point)))))
  76       (goto-char (point-min))
  77       (search-forward "@settitle ")
  78       (insert title)
  79       (search-forward "@node")
  80       (goto-char (match-beginning 0))
  81       (insert "@dircategory Emacs\n"
  82               "@direntry\n* "
  83               title
  84               ": ("
  85               rng-manual-info
  86               ").\n@end direntry\n\n"))))
  87
  88 (defvar rng-manual-inline-elements '(kbd key samp code var emph uref point))
  89
  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)
  96         (want-blank-line 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)
 108                     (when startp
 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 "}")))
 117                    ((eq name 'ulist)
 118                     (when startp
 119                       (rng-manual-output-force-blank-line)
 120                       (setq want-blank-line nil)
 121                       (princ "@itemize @bullet\n"))
 122                     (when endp
 123                       (rng-manual-output-force-new-line)
 124                       (setq want-blank-line 'noindent)
 125                       (princ "@end itemize\n")))
 126                    ((eq name 'item)
 127                     (rng-manual-output-force-new-line)
 128                     (setq want-blank-line endp)
 129                     (when startp (princ "@item\n")))
 130                    ((memq name '(example display))
 131                     (when startp
 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)))
 137                     (when endp
 138                       (rng-manual-output-force-new-line)
 139                       (setq want-blank-line 'noindent)
 140                       (princ (format "@end %s\n" name))))
 141                    ((eq name 'para)
 142                     (rng-manual-output-force-new-line)
 143                     (when startp
 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)))
 148                    ((eq name 'section)
 149                     (when startp
 150                       (rng-manual-output-force-blank-line)
 151                       (when (eq section-depth 0)
 152                         (princ "@node Top\n"))
 153                       (princ "@")
 154                       (princ (nth section-depth '(top
 155                                                   chapter
 156                                                   section
 157                                                   subsection
 158                                                   subsubsection)))
 159                       (princ " ")
 160                       (setq want-blank-line nil)
 161                       (setq section-depth (1+ section-depth)))
 162                     (when endp
 163                       (rng-manual-output-force-new-line)
 164                       (setq want-blank-line nil)
 165                       (setq section-depth (1- section-depth))))
 166                    ((eq name 'title)
 167                     (when startp
 168                       (setq keep-space-for-children 'fill))
 169                     (when endp
 170                       (setq want-blank-line t)
 171                       (princ "\n"))))
 172              (when startp
 173                (setq keep-space-stack (cons keep-space-for-children
 174                                             keep-space-stack)))
 175              (when endp
 176                (setq keep-space-stack (cdr keep-space-stack))))
 177             ((memq xmltok-type '(data
 178                                  space
 179                                  char-ref
 180                                  entity-ref
 181                                  cdata-section))
 182              (setq data nil)
 183              (cond ((memq xmltok-type '(data space))
 184                     (setq data (buffer-substring-no-properties xmltok-start
 185                                                                (point))))
 186                    ((and (memq xmltok-type '(char-ref entity-ref))
 187                          xmltok-replacement)
 188                     (setq data xmltok-replacement))
 189                    ((eq xmltok-type 'cdata-section)
 190                     (setq data
 191                           (buffer-substring-no-properties (+ xmltok-start 9)
 192                                                           (- (point) 3)))))
 193              (when (and data (car keep-space-stack))
 194                (setq data (replace-regexp-in-string "[@{}]"
 195                                                     "@\\&"
 196                                                     data
 197                                                     t))
 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))
 211                  (princ data))))
 212              ))))
 213
 214 (defun rng-manual-output-force-new-line ()
 215   (save-excursion
 216     (set-buffer standard-output)
 217     (unless (eq (char-before) ?\n)
 218       (insert ?\n))))
 219
 220 (defun rng-manual-output-force-blank-line ()
 221   (save-excursion
 222     (set-buffer standard-output)
 223     (if (eq (char-before) ?\n)
 224         (unless (eq (char-before (1- (point))) ?\n)
 225           (insert ?\n))
 226       (insert "\n\n"))))
 227
 228 ;;; Timing
 229
 230 (defun rng-time-to-float (time)
 231   (+ (* (nth 0 time) 65536.0)
 232      (nth 1 time)
 233      (/ (nth 2 time) 1000000.0)))
 234
 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"
 240              function
 241              (- (rng-time-to-float end)
 242                 (rng-time-to-float start)))
 243     val))
 244
 245 (defun rng-time-tokenize-buffer ()
 246   (interactive)
 247   (rng-time-function 'rng-tokenize-buffer))
 248
 249 (defun rng-tokenize-buffer ()
 250   (save-excursion
 251     (goto-char (point-min))
 252     (xmltok-save
 253       (xmltok-forward-prolog)
 254       (while (xmltok-forward)))))
 255
 256 (defun rng-time-validate-buffer ()
 257   (interactive)
 258   (rng-time-function 'rng-validate-buffer))
 259
 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))
 267
 268 (defun rng-validate-buffer ()
 269   (save-restriction
 270     (widen)
 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
 279           (lambda () t))))
 280
 281 ;; arch-tag: 4b8c6143-daac-4888-9c61-9bea6f935f17
 282 ;;; rng-maint.el ends here