cgit.sxemacs.org Git - packages/blob - xemacs-packages/eieio/eieio-doc.el

   1 ;;; eieio-doc.el --- create texinfo documentation for an eieio class
   2
   3 ;;; Copyright (C) 1996, 1998, 1999, 2000, 2001, 2004, 2005 Eric M. Ludlam
   4 ;;
   5 ;; Author: <zappo@gnu.org>
   6 ;; RCS: $Id: eieio-doc.el,v 1.4 2007-11-26 15:01:04 michaels Exp $
   7 ;; Keywords: OO, lisp, docs
   8 ;;
   9 ;; This program is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; 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 GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  22 ;; Boston, MA 02110-1301, USA.
  23 ;;
  24 ;; Please send bug reports, etc. to zappo@gnu.org
  25
  26 ;;; Commentary:
  27 ;;
  28 ;;  Outputs into the current buffer documentation in texinfo format
  29
  30 (require 'eieio-opt)
  31
  32 ;;  for a class, all it's children, and all it's slots.
  33
  34 ;;; Code:
  35 (defvar eieiodoc-currently-in-node nil
  36   "String representing the node we go BACK to.")
  37
  38 (defvar eieiodoc-current-section-level nil
  39   "String represending what type of section header to use.")
  40
  41 (defvar eieiodoc-prev-class nil
  42   "Non-nil when while `eieiodoc-recurse' is running.
  43 Can be referenced from the recursed function.")
  44
  45 (defvar eieiodoc-next-class nil
  46   "Non-nil when `eieiodoc-recurse' is running.
  47 Can be referenced from the recursed function.")
  48
  49 (defun eieiodoc-class-nuke (root-class indexstring &optional skiplist)
  50   "Call `eieiodoc-class' after nuking everything from POINT on.
  51 ROOT-CLASS, INDEXSTRING, and SKIPLIST are the same as `eieiodoc-class'."
  52   (delete-region (point) (point-max))
  53   (sit-for 0)
  54   (eieiodoc-class root-class indexstring skiplist))
  55
  56 (defun eieiodoc-class (root-class indexstring &optional skiplist)
  57   "Create documentation starting with ROOT-CLASS.
  58 The first job is to create an indented menu of all the classes
  59 starting with `root-class' and including all it's children.  Once this
  60 is done, @nodes are created for all the subclasses.  Each node is then
  61 documented with a description of the class, a brief inheritance tree
  62 \(with xrefs) and a list of all slots in a big table.  Where each slot
  63 is inherited from is also documented.  In addition, each class is
  64 documented in the index referenced by INDEXSTRING, a two letter code
  65 described in the texinfo manual.
  66
  67 The optional third argument SKIPLIST is a list of object not to put
  68 into any menus, nodes or lists."
  69   (interactive
  70    (list (intern-soft
  71           (completing-read "Class: " (eieio-build-class-alist) nil t))
  72          (read-string "Index name (2 chars): ")))
  73   (if (looking-at "[ \t\n]+@end ignore")
  74       (goto-char (match-end 0)))
  75   (save-excursion
  76     (setq eieiodoc-currently-in-node
  77           (if (re-search-backward "@node \\([^,]+\\)" nil t)
  78               (buffer-substring (match-beginning 1) (match-end 1))
  79             "Top")
  80           eieiodoc-current-section-level
  81           (if (re-search-forward "@\\(chapter\\|\\(sub\\)*section\\)"
  82                                  (+ (point) 500) t)
  83               (progn
  84                 (goto-char (match-beginning 0))
  85                 (cond ((looking-at "@chapter") "section")
  86                       ((looking-at "@section") "subsection")
  87                       ((looking-at "@\\(sub\\)+section") "subsubsection")
  88                       (t "subsubsection")))
  89             "subsubsection")))
  90   (save-excursion
  91     (eieiodoc-main-menu root-class skiplist)
  92     (insert "\n")
  93     (eieiodoc-recurse root-class 'eieiodoc-one-node nil skiplist)))
  94
  95 (defun eieiodoc-main-menu (class skiplist)
  96   "Create a menu of all classes under CLASS indented the correct amount.
  97 SKIPLIST is a list of objects to skip"
  98   (end-of-line)
  99   (insert "\n@menu\n")
 100   (eieiodoc-recurse class (lambda (class level)
 101                         (insert "* " (make-string level ? )
 102                                 (symbol-name class) " ::\n"))
 103                 nil skiplist)
 104   (insert "@end menu\n"))
 105
 106 (defun eieiodoc-one-node (class level)
 107   "Create a node for CLASS, and for all subclasses of CLASS in order.
 108 This function should only be called by `eieiodoc-class'
 109 Argument LEVEL is the current level of recursion we have hit."
 110   (message "Building node for %s" class)
 111   (insert "\n@node " (symbol-name class) ", "
 112           (if eieiodoc-next-class (symbol-name eieiodoc-next-class) " ") ", "
 113           (if eieiodoc-prev-class (symbol-name eieiodoc-prev-class) " ") ", "
 114           eieiodoc-currently-in-node "\n"
 115           "@comment  node-name,  next,  previous,  up\n"
 116           "@" eieiodoc-current-section-level " " (symbol-name class) "\n"
 117           ;; indexstring is grabbed from parent calling function
 118           "@" indexstring "index " (symbol-name class) "\n\n")
 119   ;; Now lets create a nifty little inheritance tree
 120   (let ((cl class)
 121         (revlist nil)
 122         (depth 0))
 123     (while cl
 124       (setq revlist (cons cl revlist)
 125             cl (class-parent cl)))
 126     (insert "@table @asis\n@item Inheritance Tree:\n")
 127     (while revlist
 128       ;; root-class is dragged in from the top-level function
 129       (insert "@table @code\n@item "
 130               (if (and (child-of-class-p (car revlist) root-class)
 131                        (not (eq class (car revlist))))
 132                   (concat "@w{@xref{" (symbol-name (car revlist)) "}.}")
 133                 (symbol-name (car revlist)))
 134               "\n")
 135       (setq revlist (cdr revlist)
 136             depth (1+ depth)))
 137     ;; the value of rclass is brought in from caller
 138     (let ((clist (reverse (aref (class-v rclass) class-children))))
 139       (if (not clist)
 140           (insert "No children")
 141         (insert "@table @asis\n@item Children:\n")
 142         (while clist
 143           (insert "@w{@xref{" (symbol-name (car clist)) "}")
 144           (if (cdr clist) (insert ",") (insert "."))
 145           (insert "} ")
 146           (setq clist (cdr clist)))
 147         (insert "\n@end table\n")
 148         ))
 149     (while (> depth 0)
 150       (insert "\n@end table\n")
 151       (setq depth (1- depth)))
 152     (insert "@end table\n\n  "))
 153   ;; Now lets build some documentation by extracting information from
 154   ;; the class description vector
 155   (let* ((cv (class-v class))
 156          (docs (aref cv class-public-doc))
 157          (names (aref cv class-public-a))
 158          (deflt (aref cv class-public-d))
 159          (prot (aref cv class-protection))
 160          (typev (aref cv class-public-type))
 161          (i 0)
 162          (set-one nil)
 163          (anchor nil)
 164          )
 165     ;; doc of the class itself
 166     (insert (eieiodoc-texify-docstring (documentation class) class)
 167             "\n\n@table @asis\n")
 168     (if names
 169         (progn
 170           (setq anchor (point))
 171           (insert "@item Slots:\n\n@table @code\n")
 172           (while names
 173             (if (eieiodoc-one-attribute class (car names) (car docs)
 174                                         (car prot) (car deflt) (aref typev i))
 175                 (setq set-one t))
 176             (setq names (cdr names)
 177                   docs (cdr docs)
 178                   prot (cdr prot)
 179                   deflt (cdr deflt)
 180                   i (1+ i)))
 181           (insert "@end table\n\n")
 182           (if (not set-one) (delete-region (point) anchor))
 183           ))
 184     (insert "@end table\n")
 185     ;; Finally, document all the methods associated with this class.
 186     (let ((methods (eieio-all-generic-functions class))
 187           (doc nil))
 188       (if (not methods) nil
 189         (if (string= eieiodoc-current-section-level "subsubsection")
 190             (insert "@" eieiodoc-current-section-level)
 191           (insert "@sub" eieiodoc-current-section-level))
 192         (insert " Specialized Methods\n\n")
 193         (while methods
 194           (setq doc (eieio-method-documentation (car methods) class))
 195           (insert "@deffn Method " (symbol-name (car methods)))
 196           (if (not doc)
 197               (insert "\n  Undocumented")
 198             (if (car doc)
 199                 (progn
 200                   (insert " :BEFORE ")
 201                   (eieiodoc-output-deffn-args (car (car doc)))
 202                   (insert "\n")
 203                   (eieiodoc-insert-and-massage-docstring-with-args
 204                    (cdr (car doc)) (car (car doc)) class)))
 205             (setq doc (cdr doc))
 206             (if (car doc)
 207                 (progn
 208                   (insert " :PRIMARY ")
 209                   (eieiodoc-output-deffn-args (car (car doc)))
 210                   (insert "\n")
 211                   (eieiodoc-insert-and-massage-docstring-with-args
 212                    (cdr (car doc)) (car (car doc)) class)))
 213             (setq doc (cdr doc))
 214             (if (car doc)
 215                 (progn
 216                   (insert " :AFTER ")
 217                   (eieiodoc-output-deffn-args (car (car doc)))
 218                   (insert "\n")
 219                   (eieiodoc-insert-and-massage-docstring-with-args
 220                    (cdr (car doc)) (car (car doc)) class)))
 221             (insert "\n@end deffn\n\n"))
 222           (setq methods (cdr methods)))))
 223     ))
 224
 225 (defun eieiodoc-insert-and-massage-docstring-with-args (doc arglst class)
 226   "Update DOC with texinfo strings using ARGLST with @var.
 227 Argument CLASS is the class passed to `eieiodoc-texify-docstring'."
 228   (let ((start (point))
 229         (end nil)
 230         (case-fold-search nil))
 231     ;; Insert the text
 232     (insert (eieiodoc-texify-docstring doc class))
 233     (setq end (point))
 234     (save-restriction
 235       (narrow-to-region start end)
 236       (save-excursion
 237         ;; Now find arguments
 238         (while arglst
 239           (goto-char (point-min))
 240           (while (re-search-forward (upcase (symbol-name (car arglst))) nil t)
 241             (replace-match "@var{\\&}" t))
 242           (setq arglst (cdr arglst)))))))
 243
 244 (defun eieiodoc-output-deffn-args (arglst)
 245   "Output ARGLST for a deffn."
 246   (while arglst
 247     (insert (symbol-name (car arglst)) " ")
 248     (setq arglst (cdr arglst))))
 249
 250 (defun eieiodoc-one-attribute (class attribute doc priv deflt type)
 251   "Create documentation of CLASS for a single ATTRIBUTE.
 252 Assume this attribute is inside a table, so it is initiated with the
 253 @item indicator.  If this attribute is not inserted (because it is
 254 contained in the parent) then return nil, else return t.
 255 DOC is the documentation to use, PRIV is non-nil if it is a private slot,
 256 and DEFLT is the default value.  TYPE is the symbol describing what type
 257 validation is done on that slot."
 258   (let ((pv (eieiodoc-parent-diff class attribute))
 259         (ia (eieio-attribute-to-initarg class attribute))
 260         (set-me nil))
 261     (if (or (eq pv t) (not ia))
 262         nil  ;; same in parent or no init arg
 263       (setq set-me t)
 264       (insert "@item " (if priv "Private: " "")
 265               (symbol-name ia))
 266       (if (and type (not (eq type t)))
 267           (insert "\nType: @code{" (format "%S" type) "}"))
 268       (if (not (eq deflt eieio-unbound))
 269           (insert " @*\nDefault Value: @code{"(format "%S" deflt) "}"))
 270       (insert "\n\n")
 271       (if (eq pv 'default)
 272           ;; default differs only, xref the parent
 273           ;; This should be upgraded to actually search for the last
 274           ;; differing default (or the original.)
 275           (insert "@xref{" (symbol-name (class-parent class)) "}.\n")
 276         (insert (if doc (eieiodoc-texify-docstring doc class) "Not Documented")
 277                 "\n@refill\n\n")))
 278     set-me))
 279 ;;;
 280 ;; Utilities
 281 ;;
 282 (defun eieiodoc-recurse (rclass func &optional level skiplist)
 283   "Recurse down all children of RCLASS, calling FUNC on each one.
 284 LEVEL indicates the current depth below the first call we are.  The
 285 function FUNC will be called with RCLASS and LEVEL.  This will then
 286 recursivly call itself once for each child class of RCLASS.  The
 287 optional fourth argument SKIPLIST is a list of objects to ignore while
 288 recursing."
 289
 290   (if (not level) (setq level 0))
 291
 292   ;; we reverse the children so they appear in the same order as it
 293   ;; does in the code that creates them.
 294   (let* ((children (reverse (aref (class-v rclass) class-children)))
 295          (ocnc eieiodoc-next-class)
 296          (eieiodoc-next-class (or (car children) ocnc))
 297          (eieiodoc-prev-class eieiodoc-prev-class))
 298
 299     (if (not (member rclass skiplist))
 300         (progn
 301           (apply func (list rclass level))
 302
 303           (setq eieiodoc-prev-class rclass)))
 304
 305     (while children
 306       (setq eieiodoc-next-class (or (car (cdr children)) ocnc))
 307       (setq eieiodoc-prev-class (eieiodoc-recurse (car children) func (1+ level)))
 308       (setq children (cdr children)))
 309     ;; return the previous class so that the prev/next node gets it right
 310     eieiodoc-prev-class))
 311
 312 (defun eieiodoc-parent-diff (class slot)
 313   "Return nil if the parent of CLASS does not have slot SLOT.
 314 Return t if it does, and return 'default if the default has changed."
 315   (let ((df nil) (err t)
 316         (scoped-class (class-parent class))
 317         (eieio-skip-typecheck))
 318     (condition-case nil
 319         (setq df (eieio-oref-default (class-parent class) slot)
 320               err nil)
 321       (invalid-slot-name (setq df nil))
 322       (error (setq df nil)))
 323     (if err
 324         nil
 325       (if (equal df (eieio-oref-default class slot))
 326           t
 327         'default))))
 328
 329 (defun eieiodoc-texify-docstring (string class)
 330   "Take STRING, (a normal doc string), and convert it into a texinfo string.
 331 For instances where CLASS is the class being referenced, do not Xref
 332 that class.
 333
 334  `function' => @dfn{function}
 335  `variable' => @code{variable}
 336  `class'    => @code{class} @xref{class}
 337  `unknown'  => @code{unknonwn}
 338  'quoteme   => @code{quoteme}
 339  non-nil    => non-@code{nil}
 340  t          => @code{t}
 341  :tag       => @code{:tag}
 342  [ stuff ]  => @code{[ stuff ]}
 343  Key        => @kbd{Key}"
 344   (while (string-match "`\\([-a-zA-Z0-9]+\\)'" string)
 345     (let* ((vs (substring string (match-beginning 1) (match-end 1)))
 346            (v (intern-soft vs)))
 347       (setq string
 348             (concat
 349              (replace-match (concat
 350                              (if (and (not (class-p v))(fboundp v))
 351                                  "@dfn{" "@code{")
 352                              vs "}"
 353                              (if (and (class-p v) (not (eq v class)))
 354                                  (concat " @xref{" vs "}.")))
 355                             nil t string)))))
 356   (while (string-match "\\( \\|^\\|-\\)\\(nil\\|t\\|'[-a-zA-Z0-9]+\\|:[-a-zA-Z0-9]+\\)\\([ ,]\\|$\\)" string)
 357     (setq string (replace-match "@code{\\2}" t nil string 2)))
 358   (while (string-match "\\( \\|^\\)\\(\\[[^]]+\\]\\)\\( \\|$\\)" string)
 359     (setq string (replace-match "@code{\\2}" t nil string 2)))
 360   (while (string-match "\\( \\|^\\)\\(\\(\\(C-\\|M-\\|S-\\)+\\([^ \t\n]\\|RET\\|SPC\\|TAB\\)\\)\\|\\(RET\\|SPC\\|TAB\\)\\)\\( \\|$\\)" string)
 361     (setq string (replace-match "@kbd{\\2}" t nil string 2)))
 362   string)
 363
 364 (provide 'eieio-doc)
 365
 366 ;;; eieio-doc.el ends here