cgit.sxemacs.org Git - packages/blob - xemacs-packages/psgml/psgml-info.el

   1 ;;;; psgml-info.el
   2 ;;; Last edited: 2000-11-09 19:23:50 lenst
   3 ;;; $Id: psgml-info.el,v 2.16 2005/02/27 17:12:05 lenst Exp $
   4
   5 ;; Copyright (C) 1994, 1995 Lennart Staflin
   6
   7 ;; Author: Lennart Staflin <lenst@lysator.liu.se>
   8
   9 ;; This program is free software; you can redistribute it and/or
  10 ;; modify it under the terms of the GNU General Public License
  11 ;; as published by the Free Software Foundation; either version 2
  12 ;; of the License, or (at your option) any later version.
  13 ;;
  14 ;; This program is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18 ;;
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with this program; if not, write to the Free Software
  21 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  22
  23 \f
  24 ;;;; Commentary:
  25
  26 ;; This file is an addon to the PSGML package.
  27
  28 ;; This file contains some commands to print out information about the
  29 ;; current DTD.
  30
  31 ;; sgml-list-elements
  32 ;;    Will list all elements and the attributes declared for the element.
  33
  34 ;; sgml-list-attributes
  35 ;;    Will list all attributes declared and the elements that use them.
  36
  37 ;; sgml-list-terminals
  38 ;;    Will list all elements that can contain data.
  39
  40 ;; sgml-list-occur-in-elements
  41 ;;    Will list all element types and where it can occur.
  42
  43 ;; sgml-list-content-elements
  44 ;;    Will list all element types and the element types that can occur
  45 ;;    in its content.
  46 \f
  47 ;;;; Code:
  48
  49 (provide 'psgml-info)
  50 (require 'psgml)
  51 (require 'psgml-parse)
  52
  53 (defconst sgml-attr-col 18)
  54
  55 (eval-when-compile (require 'cl))
  56 \f
  57 ;;;; Utility functions
  58
  59 (defsubst sgml-add-to-table (row-index elem table)
  60   (let ((p (assoc row-index table)))
  61     (cond ((null p)
  62            (cons (list row-index elem) table))
  63           (t
  64            (nconc p (list elem))
  65            table))))
  66
  67 (defsubst sgml-add-last-unique (x l)
  68   (unless (memq x l)
  69     (nconc l (list x))))
  70
  71 (defun sgml-map-element-types (func)
  72   (sgml-need-dtd)
  73   (sgml-map-eltypes func
  74                     (sgml-pstate-dtd sgml-buffer-parse-state)
  75                     t))
  76
  77
  78 (defun sgml-set-difference (l1 l2)
  79   (if (or (null l1) (null l2))
  80       l1
  81     (let ((res nil))
  82       (while l1
  83         (or (member (car l1)
  84                    l2)
  85             (push (car l1) res))
  86         (pop l1))
  87       res)))
  88
  89 (defun sgml-union (l1 l2)
  90   (cond ((null l1) l2) ((null l2) l1)
  91         ((equal l1 l2) l1)
  92         (t
  93          (or (>= (length l1) (length l2))
  94              (setq l1 (prog1 l2 (setq l2 l1))))
  95          (while l2
  96            (or (member (car l2) l1)
  97                (push (car l2) l1))
  98            (pop l2))
  99          l1)))
 100
 101 (defun sgml-eltype-refrenced-elements (eltype)
 102   "List of element types referenced in the model of ELTYPE."
 103   ;; Now with cache. Uses appdata prop re-cache.
 104   (or
 105    (sgml-eltype-appdata eltype 're-cache)
 106    (let* ((res                          ; result list (eltypes)
 107            nil)
 108           (states                       ; list of states
 109            (list (sgml-eltype-model eltype)))
 110           (agenda                       ; point into states
 111            states))
 112      (cond
 113       ((not (sgml-model-group-p (car states)))
 114        nil)
 115       (t
 116        (while agenda
 117          (cond
 118           ((sgml-normal-state-p (car agenda))
 119            (loop for m in (append (sgml-state-opts (car agenda))
 120                                   (sgml-state-reqs (car agenda)))
 121                  do
 122                  (add-to-list 'res (sgml-move-token m))
 123                  (sgml-add-last-unique (sgml-move-dest m) states)))
 124
 125           (t                            ; &-node
 126            (sgml-add-last-unique (sgml-and-node-next (car agenda)) states)
 127            (loop for dfa in (sgml-and-node-dfas (car agenda)) do
 128                  (sgml-add-last-unique dfa states))))
 129          (setq agenda (cdr agenda)))
 130        (setq res
 131              (sort (copy-sequence (sgml-set-difference
 132                                    (sgml-union res (sgml-eltype-includes eltype))
 133                                    (sgml-eltype-excludes eltype)))
 134                    (function string-lessp)))
 135        (setf (sgml-eltype-appdata eltype 're-cache) res)
 136        res)))))
 137
 138 \f
 139 ;;;; List elements
 140
 141 (defun sgml-list-elements ()
 142   "List the elements and their attributes in the current DTD."
 143   (interactive)
 144   (message "Creating table...")
 145   (sgml-display-table
 146    (sgml-map-element-types
 147     (function
 148      (lambda (eltype)
 149        (cons (sgml-eltype-name eltype)
 150              (mapcar (function sgml-attdecl-name)
 151                      (sgml-eltype-attlist eltype))))))
 152    "Elements" "Element" "Attribute"))
 153
 154 \f
 155 ;;;; List attributes
 156
 157 (defun sgml-list-attributes ()
 158   "List the attributes and in which elements they occur."
 159   (interactive)
 160   (let ((attributes nil))
 161     (message "Creating table...")
 162     (sgml-map-element-types
 163      (function
 164       (lambda (eltype)
 165         (loop for a in (sgml-eltype-attlist eltype) do
 166               (setq attributes
 167                     (sgml-add-to-table (sgml-attdecl-name a)
 168                                        (sgml-eltype-name eltype)
 169                                        attributes))))))
 170     (sgml-display-table attributes
 171                         "Attributes" "Attribute" "Element")))
 172
 173
 174
 175 \f
 176 ;;;; List terminals
 177
 178 (defun sgml-list-terminals ()
 179   "List the elements that can have data in their content."
 180   (interactive)
 181   (message "Creating table...")
 182   (let ((data-models (list sgml-cdata sgml-rcdata sgml-any)))
 183     (sgml-display-table
 184      (delq nil
 185            (sgml-map-element-types
 186             (function
 187              (lambda (eltype)
 188                (if (or (sgml-eltype-mixed eltype)
 189                        (memq (sgml-eltype-model eltype) data-models))
 190                    (list (sgml-eltype-name eltype)
 191                          (symbol-name
 192                           (if (sgml-model-group-p (sgml-eltype-model eltype))
 193                               'mixed
 194                             (sgml-eltype-model eltype)))))))))
 195      "Terminals" "Element" "Content")))
 196
 197 \f
 198 ;;;; Element cross reference list
 199
 200 (defun sgml-list-content-elements ()
 201   "List all element types and the element types that can occur in its content."
 202   (interactive)
 203   (message "Creating table...")
 204   (sgml-display-table
 205    (sgml-map-element-types
 206     (function
 207      (lambda (eltype)
 208        (cons (sgml-eltype-name eltype)
 209              (mapcar (function sgml-eltype-name)
 210                      (sgml-eltype-refrenced-elements eltype))))))
 211    "Elements referenced by elements"
 212    "Element" "Content"))
 213
 214 (defun sgml-list-occur-in-elements ()
 215   "List all element types and where it can occur."
 216   (interactive)
 217   (message "Creating table...")
 218   (let ((cross nil))
 219     (sgml-map-element-types
 220      (function
 221       (lambda (eltype)
 222         (loop for ref in (sgml-eltype-refrenced-elements eltype)
 223               do (setq cross (sgml-add-to-table ref
 224                                                 (sgml-eltype-name eltype)
 225                                                 cross))))))
 226     (sgml-display-table
 227      cross
 228      "Cross referenced element types" "Element" "Can occur in")))
 229
 230 \f
 231 ;;;; Display table
 232
 233 (defun sgml-display-table (table title col-title1 col-title2
 234                                  &optional width nosort)
 235   (or width
 236       (setq width sgml-attr-col))
 237   (let ((buf (get-buffer-create (format "*%s*" title))))
 238     (message "Preparing display...")
 239     (set-buffer buf)
 240     (erase-buffer)
 241     (insert col-title1)
 242     (indent-to width)
 243     (insert col-title2 "\n")
 244     (insert-char ?= (length col-title1))
 245     (indent-to width)
 246     (insert-char ?= (length col-title2))
 247     (insert "\n")
 248     (unless nosort
 249       (setq table (sort table (function (lambda (a b)
 250                                           (string< (car a) (car b)))))))
 251     (loop for e in table do
 252           (insert (format "%s " (car e)))
 253           (loop for name in (if nosort
 254                                 (cdr e)
 255                               (sort (cdr e) (function string-lessp)))
 256                 do
 257                 (when (> (+ (length name) (current-column))
 258                          fill-column)
 259                   (insert "\n"))
 260                 (when (< (current-column) sgml-attr-col)
 261                   (indent-to width))
 262                 (insert  name " "))
 263           (insert "\n"))
 264     (goto-char (point-min))
 265     (display-buffer buf)
 266     (message nil)))
 267
 268 \f
 269 ;;;; Describe entity
 270
 271 (defun sgml-describe-entity (name)
 272   "Describe the properties of an entity as declared in the current DTD."
 273   (interactive
 274    (let (default input)
 275      (sgml-need-dtd)
 276      (save-excursion
 277        (sgml-with-parser-syntax
 278         (unless (sgml-parse-delim "ERO")
 279           (skip-chars-backward "^&\"'= \t\n"))
 280         (setq default (or (sgml-parse-name t) ""))))
 281      (setq input (completing-read
 282                   (format "Entity name (%s): " default)
 283                   (sgml-entity-completion-table
 284                    (sgml-dtd-entities
 285                     (sgml-pstate-dtd sgml-buffer-parse-state)))))
 286      (list
 287       (if (equal "" input) default input))))
 288
 289   (with-output-to-temp-buffer "*Help*"
 290     (let ((entity (sgml-lookup-entity name
 291                                       (sgml-dtd-entities
 292                                        (sgml-pstate-dtd
 293                                         sgml-buffer-parse-state)))))
 294       (or entity (error "Undefined entity"))
 295       (princ (format "Entity %s is %s\n"
 296                      name
 297                      (cond ((null entity)
 298                             "undefined")
 299                            (t
 300                             (format "a %s entity"
 301                                     (sgml-entity-type entity))))))
 302       (when entity
 303         (let ((text (sgml-entity-text entity))
 304               (notation (sgml-entity-notation entity)))
 305           (cond ((stringp text)
 306                  (princ "Defined to be:\n")
 307                  (princ text))
 308                 (t
 309                  (princ "With external identifier ")
 310                  (princ (if (car text) "PUBLIC" "SYSTEM"))
 311                  (when (car text)
 312                    (princ (format " '%s'" (car text))))
 313                  (when (cdr text)
 314                    (princ (format " '%s'" (cdr text))))
 315                  (when notation
 316                    (princ (format "\nand notation '%s'" notation))))))))))
 317
 318
 319 \f
 320 ;;;; Describe element type
 321
 322 (defun sgml-princ-names (names &optional first sep)
 323   (setq sep (or sep " "))
 324   (loop with col = 0
 325         for name in names
 326         for this-sep = (if first (prog1 first (setq first nil)) sep)
 327         do
 328         (princ this-sep)
 329         (incf col (length this-sep))
 330         (when (and (> col 0) (> (+ col (length name)) fill-column))
 331           (princ "\n ")
 332           (setq col 1))
 333         (princ name)
 334         (incf col (length name))))
 335
 336 (defun sgml-describe-element-type (et-name)
 337   "Describe the properties of an element type as declared in the current DTD."
 338   (interactive
 339    (let (default input)
 340      (sgml-need-dtd)
 341      (save-excursion
 342        (sgml-with-parser-syntax
 343         (unless (sgml-parse-delim "STAGO")
 344           (skip-syntax-backward "w_"))
 345         (setq default (sgml-parse-name))
 346         (unless (and default
 347                      (sgml-eltype-defined (sgml-lookup-eltype default)))
 348           (setq default nil))))
 349      (setq input (sgml-read-element-type (if default
 350                                              (format "Element type (%s): "
 351                                                      default)
 352                                            "Element type: ")
 353                                          sgml-dtd-info
 354                                          default))
 355
 356      (list
 357       (sgml-eltype-name input))))
 358
 359   (sgml-need-dtd)
 360   (let ((et (sgml-lookup-eltype et-name)))
 361     (with-output-to-temp-buffer "*Help*"
 362       (princ (format "ELEMENT: %s\n\n" (sgml-eltype-name et)))
 363       (princ (format " Start-tag is %s.\n End-tag is %s.\n"
 364                      (if (sgml-eltype-stag-optional et)
 365                          "optional" "required")
 366                      (if (sgml-eltype-etag-optional et)
 367                          "optional" "required")))
 368       (princ "\nATTRIBUTES:\n")
 369       (loop for attdecl in (sgml-eltype-attlist et) do
 370             (let ((name (sgml-attdecl-name attdecl))
 371                   (dval (sgml-attdecl-declared-value attdecl))
 372                   (defl (sgml-attdecl-default-value attdecl)))
 373               (when (listp dval)
 374                 (setq dval (concat (if (eq (first dval)
 375                                            'NOTATION)
 376                                        "#NOTATION (" "(")
 377                                    (mapconcat (function identity)
 378                                               (second dval)
 379                                               "|")
 380                                    ")")))
 381               (cond ((sgml-default-value-type-p 'FIXED defl)
 382                      (setq defl (format "#FIXED '%s'"
 383                                         (sgml-default-value-attval defl))))
 384                     ((symbolp defl)
 385                      (setq defl (upcase (format "#%s" defl))))
 386                     (t
 387                      (setq defl (format "'%s'"
 388                                         (sgml-default-value-attval defl)))))
 389               (princ (format " %-9s %-30s %s\n" name dval defl))))
 390       ;; ----
 391       (let ((s (sgml-eltype-shortmap et)))
 392         (when s
 393           (princ (format "\nUSEMAP: %s\n" s))))
 394       ;; ----
 395       (princ "\nCONTENT: ")
 396       (cond ((symbolp (sgml-eltype-model et)) (princ (sgml-eltype-model et)))
 397             (t
 398              (princ (if (sgml-eltype-mixed et) "mixed\n\n"
 399                       "element\n\n"))
 400              (sgml-princ-names
 401               (mapcar #'symbol-name (sgml-eltype-refrenced-elements et)))))
 402       (let ((incl (sgml-eltype-includes et))
 403             (excl (sgml-eltype-excludes et)))
 404         (when (or incl excl)
 405           (princ "\n\nEXCEPTIONS:"))
 406         (when incl
 407           (princ "\n + ")
 408           (sgml-princ-names (mapcar #'symbol-name incl)))
 409         (when excl
 410           (princ "\n - ")
 411           (sgml-princ-names (mapcar #'symbol-name excl))))
 412       ;; ----
 413       (princ "\n\nOCCURS IN:\n\n")
 414       (let ((occurs-in ()))
 415         (sgml-map-eltypes
 416          (function (lambda (cand)
 417                      (when (memq et (sgml-eltype-refrenced-elements cand))
 418                        (push cand occurs-in))))
 419          (sgml-pstate-dtd sgml-buffer-parse-state))
 420         (sgml-princ-names (mapcar 'sgml-eltype-name
 421                                   (sort occurs-in (function string-lessp))))))))
 422
 423 \f
 424 ;;;; Print general info about the DTD.
 425
 426 (defun sgml-describe-dtd ()
 427   "Display information about the current DTD."
 428   (interactive)
 429   (sgml-need-dtd)
 430   (let ((elements 0)
 431         (entities 0)
 432         (parameters 0)
 433         (fmt "%20s %s\n")
 434         (hdr ""))
 435
 436     (sgml-map-eltypes (function (lambda (e) (incf elements)))
 437                       sgml-dtd-info)
 438     (sgml-map-entities (function (lambda (e) (incf entities)))
 439                        (sgml-dtd-entities sgml-dtd-info))
 440     (sgml-map-entities (function (lambda (e) (incf parameters)))
 441                        (sgml-dtd-parameters sgml-dtd-info))
 442
 443     (with-output-to-temp-buffer "*Help*"
 444       (princ (format fmt "Doctype:" (sgml-dtd-doctype sgml-dtd-info)))
 445       (when (sgml-dtd-merged sgml-dtd-info)
 446         (princ (format fmt "Compiled DTD:"
 447                        (car (sgml-dtd-merged sgml-dtd-info)))))
 448       (princ (format fmt "Element types:" (format "%d" elements)))
 449       (princ (format fmt "Entities:" (format "%d" entities)))
 450       (princ (format fmt "Parameter entities:" (format "%d" parameters)))
 451
 452       (setq hdr "Files used:")
 453       (loop for x in (sgml-dtd-dependencies sgml-dtd-info)
 454             if (stringp x)
 455             do (princ (format fmt hdr x))
 456             (setq hdr ""))
 457
 458       (setq hdr "Undef parameters:")
 459       (sgml-map-entities
 460        (function (lambda (entity)
 461                    (when (sgml-entity-marked-undefined-p entity)
 462                      (princ (format fmt hdr (sgml-entity-name entity)))
 463                      (setq hdr ""))))
 464        (sgml-dtd-parameters sgml-dtd-info)))))
 465
 466
 467 (defalias 'sgml-general-dtd-info 'sgml-describe-dtd)
 468
 469 \f
 470 ;;; psgml-info.el ends here