writer-texinfo.lisp

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