writer-texinfo.lisp

   1 ;;; -*- lisp -*-
   2
   3 ;;;; A docstring extractor for the sbcl manual.  Creates
   4 ;;;; @include-ready documentation from the docstrings of exported
   5 ;;;; symbols of specified packages.
   6
   7 ;;;; This software was originally part of the SBCL software system.
   8 ;;;; SBCL is in the public domain and is provided with absolutely no warranty.
   9 ;;;; See the COPYING file for more information.
  10 ;;;;
  11 ;;;; Written by Rudi Schlatte <rudi@constantly.at>, mangled
  12 ;;;; by Nikodemus Siivola, Luis Oliveira, David Lichteblau, and others.
  13
  14 (in-package #:texinfo-docstrings)
  15
  16 (define-document-format :texinfo "texinfo")
  17
  18 ;;; If T, package names are prepended in the documentation.  This
  19 ;;; doesn't affect filenames.  For now this value is sort of hardcoded
  20 ;;; in GENERATE-INCLUDES.  Fix that.
  21 (defvar *prepend-package-names*)
  22
  23 (defparameter *texinfo-escaped-chars* "@{}"
  24   "Characters that must be escaped with #\@ for Texinfo.")
  25
  26 (defparameter *undocumented-packages*
  27   #+sbcl '(sb-pcl sb-int sb-kernel sb-sys sb-c)
  28   #-sbcl nil)
  29
  30 (defparameter *character-replacements*
  31   '((#\* . "star") (#\/ . "slash") (#\+ . "plus")
  32     (#\< . "lt") (#\> . "gt"))
  33   "Characters and their replacement names that `alphanumize' uses. If
  34 the replacements contain any of the chars they're supposed to replace,
  35 you deserve to lose.")
  36
  37 (defparameter *characters-to-drop* '(#\\ #\` #\')
  38   "Characters that should be removed by `alphanumize'.")
  39
  40 (defun alphanumize (original)
  41   "Construct a string without characters like *`' that will f-star-ck
  42 up filename handling. See `*character-replacements*' and
  43 `*characters-to-drop*' for customization."
  44   (let ((name (remove-if (lambda (x) (member x *characters-to-drop*))
  45                          (if (listp original)
  46                              (flatten-to-string original)
  47                              (string original))))
  48         (chars-to-replace (mapcar #'car *character-replacements*)))
  49     (flet ((replacement-delimiter (index)
  50              (cond ((or (< index 0) (>= index (length name))) "")
  51                    ((alphanumericp (char name index)) "-")
  52                    (t ""))))
  53       (loop for index = (position-if #'(lambda (x) (member x chars-to-replace))
  54                                      name)
  55          while index
  56          do (setf name (concatenate 'string (subseq name 0 index)
  57                                     (replacement-delimiter (1- index))
  58                                     (cdr (assoc (aref name index)
  59                                                 *character-replacements*))
  60                                     (replacement-delimiter (1+ index))
  61                                     (subseq name (1+ index))))))
  62     name))
  63
  64 (defun include-pathname (doc)
  65   (let* ((kind (parse-docstrings:get-kind doc))
  66          (name (nstring-downcase
  67                 (if (eq 'package kind)
  68                     (format nil "package-~A"
  69                             (alphanumize (parse-docstrings:get-name doc)))
  70                     (format nil "~A-~A-~A"
  71                             (case (parse-docstrings:get-kind doc)
  72                               ((function generic-function) "fun")
  73                               (structure "struct")
  74                               (variable "var")
  75                               (otherwise
  76                                (symbol-name (parse-docstrings:get-kind doc))))
  77                             (alphanumize
  78                              (parse-docstrings:get-package-name doc))
  79                             (alphanumize
  80                              (parse-docstrings:get-name doc)))))))
  81     (make-pathname :name name  :type "texinfo")))
  82
  83 ;;; Node names for DOCUMENTATION instances
  84
  85 (defun package-name-prefix (doc)
  86   (format nil "~@[~A:~]"
  87           (and *prepend-package-names*
  88                (parse-docstrings:get-package-name doc))))
  89
  90 (defgeneric name-using-kind/name (kind name doc))
  91
  92 (defmethod name-using-kind/name (kind (name string) doc)
  93   (declare (ignore kind doc))
  94   name)
  95
  96 (defmethod name-using-kind/name (kind (name symbol) doc)
  97   (declare (ignore kind))
  98   (format nil "~A~A" (package-name-prefix doc) name))
  99
 100 (defmethod name-using-kind/name (kind (name list) doc)
 101   (declare (ignore kind))
 102   (assert (parse-docstrings:setf-name-p name))
 103   (format nil "(setf ~A~A)" (package-name-prefix doc) (second name)))
 104
 105 (defmethod name-using-kind/name ((kind (eql 'method)) name doc)
 106   (format nil "~A~{ ~A~} ~A"
 107           (name-using-kind/name nil (first name) doc)
 108           (second name)
 109           (third name)))
 110
 111 (defun node-name (doc)
 112   "Returns TexInfo node name as a string for a DOCUMENTATION instance."
 113   (let ((kind (parse-docstrings:get-kind doc)))
 114     (format nil "~:(~A~) ~(~A~)"
 115             kind
 116             (name-using-kind/name kind (parse-docstrings:get-name doc) doc))))
 117
 118 ;;; Definition titles for DOCUMENTATION instances
 119
 120 (defgeneric title-using-kind/name (kind name doc))
 121
 122 (defmethod title-using-kind/name (kind (name string) doc)
 123   (declare (ignore kind doc))
 124   name)
 125
 126 (defmethod title-using-kind/name (kind (name symbol) doc)
 127   (declare (ignore kind))
 128   (format nil "~A~A" (package-name-prefix doc) name))
 129
 130 (defmethod title-using-kind/name (kind (name list) doc)
 131   (declare (ignore kind))
 132   (assert (parse-docstrings:setf-name-p name))
 133   (format nil "(setf ~A~A)" (package-name-prefix doc) (second name)))
 134
 135 (defmethod title-using-kind/name ((kind (eql 'method)) name doc)
 136   (format nil "~{~A ~}~A"
 137           (second name)
 138           (title-using-kind/name nil (first name) doc)))
 139
 140 (defun title-name (doc)
 141   "Returns a string to be used as name of the definition."
 142   (string-downcase (title-using-kind/name (parse-docstrings:get-kind doc)
 143                                           (parse-docstrings:get-name doc)
 144                                           doc)))
 145
 146
 147 ;;;; turning text into texinfo
 148
 149 (defun texinfo-escape (string &optional downcasep)
 150   "Return STRING with characters in *TEXINFO-ESCAPED-CHARS* escaped
 151 with #\@. Optionally downcase the result."
 152   (let ((result (with-output-to-string (s)
 153                   (loop for char across string
 154                         when (find char *texinfo-escaped-chars*)
 155                         do (write-char #\@ s)
 156                         do (write-char char s)))))
 157     (if downcasep (nstring-downcase result) result)))
 158
 159
 160 ;;;; texinfo formatting tools
 161
 162 (defun hide-superclass-p (class-name super-name)
 163   (let ((super-package (symbol-package super-name)))
 164     (or
 165      ;; KLUDGE: We assume that we don't want to advertise internal
 166      ;; classes in CP-lists, unless the symbol we're documenting is
 167      ;; internal as well.
 168      (and (member super-package
 169                   #.'(mapcar #'find-package *undocumented-packages*))
 170           (not (eq super-package (symbol-package class-name))))
 171      ;; KLUDGE: We don't generally want to advertise SIMPLE-ERROR or
 172      ;; SIMPLE-CONDITION in the CPLs of conditions that inherit them
 173      ;; simply as a matter of convenience. The assumption here is that
 174      ;; the inheritance is incidental unless the name of the condition
 175      ;; begins with SIMPLE-.
 176      (and (member super-name '(simple-error simple-condition))
 177           (let ((prefix "SIMPLE-"))
 178             (mismatch prefix (string class-name) :end2 (length prefix)))
 179           t ; don't return number from MISMATCH
 180           ))))
 181
 182 (defun hide-slot-p (symbol slot)
 183   ;; FIXME: There is no pricipal reason to avoid the slot docs fo
 184   ;; structures and conditions, but their DOCUMENTATION T doesn't
 185   ;; currently work with them the way we'd like.
 186   (not (and (typep (find-class symbol nil) 'standard-class)
 187             (parse-docstrings::docstring slot t))))
 188
 189 (defun texinfo-anchor (doc)
 190   (format *document-output* "@anchor{~A}~%" (node-name doc)))
 191
 192 ;;; KLUDGE: &AUX *PRINT-PRETTY* here means "no linebreaks please"
 193 (defun texinfo-begin (doc &aux *print-pretty*)
 194   (let ((kind (parse-docstrings:get-kind doc)))
 195     (format *document-output* "@~A {~:(~A~)} ~(~A~@[ ~{~A~^ ~}~]~)~%"
 196             (case kind
 197               ((package constant variable)
 198                "defvr")
 199               ((structure class condition type)
 200                "deftp")
 201               (t
 202                "deffn"))
 203             (map 'string (lambda (char) (if (eql char #\-) #\Space char))
 204                  (string kind))
 205             (title-name doc)
 206             (parse-docstrings:lambda-list doc))))
 207
 208 (defun texinfo-index (doc)
 209   (let ((title (title-name doc)))
 210     (case (parse-docstrings:get-kind doc)
 211       ((structure type class condition)
 212        (format *document-output* "@tindex ~A~%" title))
 213       ((variable constant)
 214        (format *document-output* "@vindex ~A~%" title))
 215       ((compiler-macro function method-combination macro generic-function)
 216        (format *document-output* "@findex ~A~%" title)))))
 217
 218 (defun texinfo-inferred-body (doc)
 219   (when (member (parse-docstrings:get-kind doc) '(class structure condition))
 220     (let ((name (parse-docstrings:get-name doc)))
 221       ;; class precedence list
 222       (format *document-output*
 223               "Class precedence list: @code{~(~{@lw{~A}~^, ~}~)}~%~%"
 224               (remove-if (lambda (class)  (hide-superclass-p name class))
 225                          (mapcar #'class-name (ensure-class-precedence-list
 226                                                (find-class name)))))
 227       ;; slots
 228       (let ((slots (remove-if (lambda (slot) (hide-slot-p name slot))
 229                               (class-direct-slots (find-class name)))))
 230         (when slots
 231           (format *document-output* "Slots:~%@itemize~%")
 232           (dolist (slot slots)
 233             (format *document-output*
 234                     "@item ~(@code{~A}~#[~:; --- ~]~
 235                       ~:{~2*~@[~2:*~A~P: ~{@code{@w{~A}}~^, ~}~]~:^; ~}~)~%~%"
 236                     (slot-definition-name slot)
 237                     (remove
 238                      nil
 239                      (mapcar
 240                       (lambda (name things)
 241                         (if things
 242                             (list name (length things) things)))
 243                       '("initarg" "reader"  "writer")
 244                       ;; because I couldn't grok that format string
 245                       (flet ((symbol-names (list)
 246                                (mapcar (lambda (x)
 247                                          (if (or *prepend-package-names*
 248                                                  (keywordp x))
 249                                              (format nil "~(~S~)" x)
 250                                              (format nil "~(~A~)" x)))
 251                                        list)))
 252                         (mapcar #'symbol-names
 253                                 (list (slot-definition-initargs slot)
 254                                       (slot-definition-readers slot)
 255                                       (slot-definition-writers slot)))))))
 256             ;; FIXME: Would be neater to handler as children
 257             (write-texinfo-string (parse-docstrings::docstring slot t)))
 258           (format *document-output* "@end itemize~%~%"))))))
 259
 260 (defun texinfo-body (doc)
 261   (write-texinfo-string (parse-docstrings:get-string doc)))
 262
 263 (defun texinfo-end (doc)
 264   (write-line (case (parse-docstrings:get-kind doc)
 265                 ((package variable constant) "@end defvr")
 266                 ((structure type class condition) "@end deftp")
 267                 (t "@end deffn"))
 268               *document-output*))
 269
 270 (defun write-texinfo (doc)
 271   "Writes TexInfo for a DOCUMENTATION instance to *DOCUMENT-OUTPUT*."
 272   (texinfo-anchor doc)
 273   (texinfo-begin doc)
 274   (texinfo-index doc)
 275   (texinfo-inferred-body doc)
 276   (texinfo-body doc)
 277   (texinfo-end doc)
 278   ;; FIXME: Children should be sorted one way or another
 279   (mapc #'write-texinfo (parse-docstrings:get-children doc)))
 280
 281 (defmacro with-texinfo-file (pathname &body forms)
 282   `(with-open-file (*document-output* ,pathname
 283                                       :direction :output
 284                                       :if-does-not-exist :create
 285                                       :if-exists :supersede)
 286      ,@forms))
 287
 288 (defun generate-includes (directory &rest packages)
 289   "Create files in `directory' containing Texinfo markup of all
 290 docstrings of each exported symbol in `packages'. `directory' is
 291 created if necessary. If you supply a namestring that doesn't end in a
 292 slash, you lose. The generated files are of the form
 293 \"<doc-type>_<packagename>_<symbol-name>.texinfo\" and can be included
 294 via @include statements. Texinfo syntax-significant characters are
 295 escaped in symbol names, but if a docstring contains invalid Texinfo
 296 markup, you lose."
 297   (handler-bind ((warning #'muffle-warning))
 298     (let ((directory (merge-pathnames (pathname directory))))
 299       (ensure-directories-exist directory)
 300       (let ((*prepend-package-names* (> (length packages) 1)))
 301         (dolist (package packages)
 302           (dolist (doc (parse-docstrings:collect-documentation
 303                         (find-package package)
 304                         (string-downcase (etypecase package
 305                                            (symbol (symbol-name package))
 306                                            (string package)))))
 307             (with-texinfo-file
 308                 (merge-pathnames (include-pathname doc) directory)
 309               (write-texinfo doc)))))
 310       directory)))
 311
 312 ;;;; TEXINFO OUTPUT
 313
 314 (defmethod format-doc (stream
 315                        (lisp parse-docstrings:lisp-block)
 316                        (format (eql :texinfo)))
 317   (format stream "@lisp~%~A~%@end lisp"
 318           (texinfo-escape (parse-docstrings:get-string lisp))))