doc/manual/docstrings.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
   8 ;;;; This software is part of the SBCL software system. SBCL is in the
   9 ;;;; public domain and is provided with absolutely no warranty. See
  10 ;;;; the COPYING file for more information.
  11 ;;;;
  12 ;;;; Written by Rudi Schlatte <rudi@constantly.at>
  13
  14
  15 ;;;; Formatting heuristics (tweaked to format SAVE-LISP-AND-DIE sanely):
  16 ;;;;
  17 ;;;; Formats SYMBOL as @code{symbol}, or @var{symbol} if symbol is in
  18 ;;;; the argument list of the defun / defmacro.
  19 ;;;;
  20 ;;;; Lines starting with * or - that are followed by intented lines
  21 ;;;; are marked up with @itemize.
  22 ;;;;
  23 ;;;; Lines containing only a SYMBOL that are followed by indented
  24 ;;;; lines are marked up as @table @code, with the SYMBOL as the item.
  25
  26
  27
  28 (eval-when (:compile-toplevel :load-toplevel :execute)
  29   (require 'sb-introspect))
  30
  31 (defparameter *documentation-types*
  32   '(compiler-macro
  33     function
  34     method-combination
  35     setf
  36     ;;structure  ; also handled by `type'
  37     type
  38     variable)
  39   "A list of symbols accepted as second argument of `documentation'")
  40
  41 ;;; Collecting info from package
  42
  43 (defun documentation-for-symbol (symbol)
  44   "Collects all doc for a symbol, returns a list of the
  45   form (symbol doc-type docstring).  See `*documentation-types*'
  46   for the possible values of doc-type."
  47   (loop for kind in *documentation-types*
  48        for doc = (documentation symbol kind)
  49        when doc
  50        collect (list symbol kind doc)))
  51
  52 (defun collect-documentation (package)
  53   "Collects all documentation for all external symbols of the
  54   given package, as well as for the package itself."
  55   (let* ((package (find-package package))
  56          (package-doc (documentation package t))
  57          (result nil))
  58     (check-type package package)
  59     (do-external-symbols (symbol package)
  60       (let ((docs (documentation-for-symbol symbol)))
  61         (when docs (setf result (nconc docs result)))))
  62     (when package-doc
  63       (setf result (nconc (list (list (intern (package-name package) :keyword)
  64                                       'package package-doc)) result)))
  65     result))
  66
  67 ;;; Helpers for texinfo output
  68
  69 (defvar *texinfo-escaped-chars* "@{}"
  70   "Characters that must be escaped with #\@ for Texinfo.")
  71
  72 (defun texinfoify (string-designator &optional (downcase-p t))
  73   "Return 'string-designator' with characters in
  74   *texinfo-escaped-chars* escaped with #\@.  Optionally downcase
  75   the result."
  76   (let ((result (with-output-to-string (s)
  77        (loop for char across (string string-designator)
  78           when (find char *texinfo-escaped-chars*)
  79           do (write-char #\@ s)
  80           do (write-char char s)))))
  81     (if downcase-p (nstring-downcase result) result)))
  82
  83 (defvar *symbol-characters* "ABCDEFGHIJKLMNOPQRSTUVWXYZ*:-+"
  84   "List of characters that make up symbols in a docstring.")
  85
  86 (defvar *symbol-delimiters* " ,.!?;")
  87
  88 (defun locate-symbols (line)
  89   "Return a list of index pairs of symbol-like parts of LINE."
  90   ;; This would be a good application for a regex ...
  91   (do ((result nil)
  92        (begin nil)
  93        (maybe-begin t)
  94        (i 0 (1+ i)))
  95       ((= i (length line))
  96        ;; symbol at end of line
  97        (when (and begin (or (> i (1+ begin))
  98                             (not (member (char line begin) '(#\A #\I)))))
  99          (push (list begin i) result))
 100        (nreverse result))
 101     (cond
 102       ((and begin (find (char line i) *symbol-delimiters*))
 103        ;; symbol end; remember it if it's not "A" or "I"
 104        (when (or (> i (1+ begin)) (not (member (char line begin) '(#\A #\I))))
 105          (push (list begin i) result))
 106        (setf begin nil
 107              maybe-begin t))
 108       ((and begin (not (find (char line i) *symbol-characters*)))
 109        ;; Not a symbol: abort
 110        (setf begin nil))
 111       ((and maybe-begin (not begin) (find (char line i) *symbol-characters*))
 112        ;; potential symbol begin at this position
 113        (setf begin i
 114              maybe-begin nil))
 115       ((find (char line i) *symbol-delimiters*)
 116        ;; potential symbol begin after this position
 117        (setf maybe-begin t))
 118       (t
 119        ;; Not reading a symbol, not at potential start of symbol
 120        (setf maybe-begin nil)))))
 121
 122 (defun all-symbols (list)
 123   (cond ((null list) nil)
 124         ((symbolp list) (list list))
 125         ((consp list) (append (all-symbols (car list))
 126                               (all-symbols (cdr list))))
 127         (t nil)))
 128
 129
 130 (defun frob-doc-line (line var-symbols)
 131   "Format symbols in LINE texinfo-style: either as code or as
 132   variables if the symbol in question is contained in
 133   var-symbols."
 134   (with-output-to-string (result)
 135     (let ((last 0))
 136       (dolist (symbol-index (locate-symbols line))
 137         (write-string (subseq line last (first symbol-index)) result)
 138         (let ((symbol-name (apply #'subseq line symbol-index)))
 139           (format result (if (member symbol-name var-symbols
 140                                      :test #'string=)
 141                              "@var{~A}"
 142                              "@code{~A}")
 143                   (string-downcase symbol-name)))
 144         (setf last (second symbol-index)))
 145       (write-string (subseq line last) result))))
 146
 147 (defparameter *itemize-start-characters* '(#\* #\-)
 148   "Characters that might start an itemization in docstrings when
 149   at the start of a line.")
 150
 151 (defun indentation (line)
 152   "Position of first non-SPACE character in LINE."
 153   (position-if-not (lambda (c) (char= c #\Space)) line))
 154
 155 (defun maybe-itemize-offset (line)
 156   "Return NIL or the indentation offset if LINE looks like it
 157   starts an item in an itemization."
 158   (let ((offset (indentation line)))
 159     (when (and offset
 160                (member (char line offset) *itemize-start-characters*
 161                        :test #'char=))
 162       offset)))
 163
 164 (defun collect-maybe-itemized-section (lines starting-line arglist-symbols)
 165   ;; Return index of next line to be processed outside
 166   (let ((this-offset (maybe-itemize-offset (svref lines starting-line)))
 167         (result nil)
 168         (lines-consumed 0))
 169     (loop for line-number from starting-line below (length lines)
 170        for line = (svref lines line-number)
 171        for indentation = (indentation line)
 172        for offset = (maybe-itemize-offset line)
 173        do (cond
 174             ((not indentation)
 175              ;; empty line -- inserts paragraph.
 176              (push "" result)
 177              (incf lines-consumed))
 178             ((and offset (> indentation this-offset))
 179              ;; nested itemization -- handle recursively
 180              (multiple-value-bind (sub-lines-consumed sub-itemization)
 181                  (collect-maybe-itemized-section lines line-number
 182                                                  arglist-symbols)
 183                (when sub-lines-consumed
 184                  (incf line-number (1- sub-lines-consumed)) ; +1 on next loop
 185                  (incf lines-consumed sub-lines-consumed)
 186                  (setf result (nconc (nreverse sub-itemization) result)))))
 187             ((and offset (= indentation this-offset))
 188              ;; start of new item
 189              (push (format nil "@item ~A"
 190                            (frob-doc-line (subseq line (1+ offset))
 191                                           arglist-symbols))
 192                    result)
 193              (incf lines-consumed))
 194             ((and (not offset) (> indentation this-offset))
 195              ;; continued item from previous line
 196              (push (frob-doc-line line arglist-symbols) result)
 197              (incf lines-consumed))
 198             (t
 199              ;; end of itemization
 200              (loop-finish))))
 201     (if
 202      ;; a single-line itemization isn't.
 203      (> (count-if (lambda (line) (> (length line) 0)) result) 1)
 204      (values lines-consumed
 205              `("@itemize" ,@(reverse result) "@end itemize"))
 206      nil)))
 207
 208
 209 (defun maybe-table-offset (line)
 210   "Return NIL or the indentation offset if LINE looks like it
 211   starts an item in a tabulation, i.e., there's only a symbol on the line."
 212   (let ((offset (indentation line)))
 213     (when (and offset
 214                (every (lambda (c)
 215                         (or (char= c #\Space)
 216                             (find c *symbol-characters* :test #'char=)))
 217                       line))
 218       offset)))
 219
 220 (defun collect-maybe-table-section (lines starting-line arglist-symbols)
 221   ;; Return index of next line to be processed outside
 222   (let ((this-offset (maybe-table-offset (svref lines starting-line)))
 223         (result nil)
 224         (lines-consumed 0))
 225     (loop for line-number from starting-line below (length lines)
 226        for line = (svref lines line-number)
 227        for indentation = (indentation line)
 228        for offset = (maybe-table-offset line)
 229        do (cond
 230             ((not indentation)
 231              ;; empty line -- inserts paragraph.
 232              (push "" result)
 233              (incf lines-consumed))
 234             ((and offset (= indentation this-offset))
 235              ;; start of new item, or continuation of previous item
 236              (if (and result (search "@item" (car result) :test #'char=))
 237                  (push (format nil "@itemx ~A"
 238                                (frob-doc-line line arglist-symbols))
 239                        result)
 240                  (progn
 241                    (push "" result)
 242                    (push (format nil "@item ~A"
 243                                  (frob-doc-line line arglist-symbols))
 244                          result)))
 245              (incf lines-consumed))
 246             ((> indentation this-offset)
 247              ;; continued item from previous line
 248              (push (frob-doc-line line arglist-symbols) result)
 249              (incf lines-consumed))
 250             (t
 251              ;; end of itemization
 252              (loop-finish))))
 253     (if
 254      ;; a single-line table isn't.
 255      (> (count-if (lambda (line) (> (length line) 0)) result) 1)
 256      (values lines-consumed
 257              `("" "@table @code" ,@(reverse result) "@end table" ""))
 258      nil)))
 259
 260 (defun string-as-lines (string)
 261   (coerce (with-input-from-string (s string)
 262             (loop for line = (read-line s nil nil)
 263                while line collect line))
 264           'vector))
 265
 266 (defun frob-docstring (docstring symbol-arglist)
 267   "Try to guess as much formatting for a raw docstring as possible."
 268   ;; Per-line processing is not necessary now, but it will be when we
 269   ;; attempt itemize / table auto-detection in docstrings
 270   (with-output-to-string (result)
 271     (let ((arglist-symbols (all-symbols symbol-arglist))
 272           (doc-lines (string-as-lines (texinfoify docstring nil))))
 273       (loop for line-number from 0 below (length doc-lines)
 274            for line = (svref doc-lines line-number)
 275          do (cond
 276               ((maybe-itemize-offset line)
 277                (multiple-value-bind (lines-consumed itemized-lines)
 278                    (collect-maybe-itemized-section doc-lines line-number
 279                                                    arglist-symbols)
 280                  (cond (lines-consumed
 281                         (dolist (item-line itemized-lines)
 282                           (write-line item-line result))
 283                         (incf line-number (1- lines-consumed)))
 284                        (t (write-line (frob-doc-line line arglist-symbols)
 285                              result)))))
 286               ((maybe-table-offset line)
 287                (multiple-value-bind (lines-consumed itemized-lines)
 288                    (collect-maybe-table-section doc-lines line-number
 289                                                    arglist-symbols)
 290                  (cond (lines-consumed
 291                         (dolist (item-line itemized-lines)
 292                           (write-line item-line result))
 293                         (incf line-number (1- lines-consumed)))
 294                        (t (write-line (frob-doc-line line arglist-symbols)
 295                              result)))))
 296               (t (write-line (frob-doc-line line arglist-symbols) result)))))))
 297
 298 ;;; Begin, rest and end of definition.
 299
 300 (defun argument-list (fname)
 301   (sb-introspect:function-arglist fname))
 302
 303 (defvar *character-replacements*
 304   '((#\* . "star") (#\/ . "slash") (#\+ . "plus"))
 305   "Characters and their replacement names that `alphanumize'
 306   uses.  If the replacements contain any of the chars they're
 307   supposed to replace, you deserve to lose.")
 308
 309 (defvar *characters-to-drop* '(#\\ #\` #\')
 310   "Characters that should be removed by `alphanumize'.")
 311
 312 (defun alphanumize (symbol)
 313   "Construct a string without characters like *`' that will
 314   f-star-ck up filename handling.  See `*character-replacements*'
 315   and `*characters-to-drop*' for customization."
 316   (let ((name (remove-if #'(lambda (x) (member x *characters-to-drop*))
 317                          (string symbol)))
 318         (chars-to-replace (mapcar #'car *character-replacements*)))
 319     (flet ((replacement-delimiter (index)
 320              (cond ((or (< index 0) (>= index (length name))) "")
 321                    ((alphanumericp (char name index)) "-")
 322                    (t ""))))
 323       (loop for index = (position-if #'(lambda (x) (member x chars-to-replace))
 324                                      name)
 325          while index
 326          do (setf name (concatenate 'string (subseq name 0 index)
 327                                     (replacement-delimiter (1- index))
 328                                     (cdr (assoc (aref name index)
 329                                                 *character-replacements*))
 330                                     (replacement-delimiter (1+ index))
 331                                     (subseq name (1+ index))))))
 332     name))
 333
 334 (defun unique-name (symbol package kind)
 335   (nstring-downcase
 336    (format nil "~A-~A-~A"
 337            (ecase kind
 338              (compiler-macro "compiler-macro")
 339              (function (cond
 340                          ((macro-function symbol) "macro")
 341                          ((special-operator-p symbol) "special-operator")
 342                          (t "fun")))
 343              (method-combination "method-combination")
 344              (package "package")
 345              (setf "setf-expander")
 346              (structure "struct")
 347              (type (let ((class (find-class symbol nil)))
 348                      (etypecase class
 349                        (structure-class "struct")
 350                        (standard-class "class")
 351                        (sb-pcl::condition-class "condition")
 352                        ((or built-in-class null) "type"))))
 353              (variable (if (constantp symbol)
 354                            "constant"
 355                            "var")))
 356            (package-name package)
 357            (alphanumize symbol))))
 358
 359 (defun def-begin (symbol kind)
 360   (ecase kind
 361     (compiler-macro "@deffn {Compiler Macro}")
 362     (function (cond
 363                 ((macro-function symbol) "@deffn Macro")
 364                 ((special-operator-p symbol) "@deffn {Special Operator}")
 365                 (t "@deffn Function")))
 366     (method-combination "@deffn {Method Combination}")
 367     (package "@defvr Package")
 368     (setf "@deffn {Setf Expander}")
 369     (structure "@deftp Structure")
 370     (type (let ((class (find-class symbol nil)))
 371             (etypecase class
 372               (structure-class "@deftp Structure")
 373               (standard-class "@deftp Class")
 374               (sb-pcl::condition-class "@deftp Condition")
 375               ((or built-in-class null) "@deftp Type"))))
 376     (variable (if (constantp symbol)
 377                   "@defvr Constant"
 378                   "@defvr Variable"))))
 379
 380 (defun def-index (symbol kind)
 381   (case kind
 382     ((compiler-macro function method-combination)
 383      (format nil "@findex ~A" (texinfoify symbol)))
 384     ((structure type)
 385      (format nil "@tindex ~A" (texinfoify symbol)))
 386     (variable
 387      (format nil "@vindex ~A" (texinfoify symbol)))))
 388
 389 (defparameter *arglist-keywords*
 390   '(&allow-other-keys &aux &body &environment &key &optional &rest &whole))
 391
 392 (defun texinfoify-arglist-part (part)
 393   (with-output-to-string (s)
 394     (etypecase part
 395       (string (prin1 (texinfoify part nil) s))
 396       (number (prin1 part s))
 397       (symbol
 398        (if (member part *arglist-keywords*)
 399            (princ (texinfoify part) s)
 400            (format s "@var{~A}" (texinfoify part))))
 401       (list
 402        (format s "(~{~A~^ ~})" (mapcar #'texinfoify-arglist-part part))))))
 403
 404 (defun def-arglist (symbol kind)
 405   (case kind
 406     (function
 407      (format nil "~{~A~^ ~}"
 408              (mapcar #'texinfoify-arglist-part (argument-list symbol))))))
 409
 410 (defun hidden-superclass-name-p (class-name superclass-name)
 411   (let ((super-package (symbol-package superclass-name)))
 412     (or
 413      ;; KLUDGE: We assume that we don't want to advertise internal
 414      ;; classes in CP-lists, unless the symbol we're documenting is
 415      ;; internal as well.
 416      (and (member super-package #.'(mapcar #'find-package '(sb-pcl sb-int sb-kernel)))
 417              (not (eq super-package (symbol-package class-name))))
 418      ;; KLUDGE: We don't generally want to advertise SIMPLE-ERROR or
 419      ;; SIMPLE-CONDITION in the CPLs of conditions that inherit them
 420      ;; simply as a matter of convenience. The assumption here is
 421      ;; that the inheritance is incidental unless the name of the
 422      ;; condition begins with SIMPLE-.
 423      (and (member superclass-name '(simple-error simple-condition))
 424           (let ((prefix "SIMPLE-"))
 425             (mismatch prefix (string class-name) :end2 (length prefix)))
 426           t ; don't return number from MISMATCH
 427           ))))
 428
 429 (defun hidden-slot-p (symbol slot)
 430   ;; FIXME: There is no pricipal reason to avoid the slot docs fo
 431   ;; structures and conditions, but their DOCUMENTATION T doesn't
 432   ;; currently work with them the way we'd like.
 433   (not (and (typep (find-class symbol nil) 'standard-class)
 434             (documentation slot t))))
 435
 436 (defun classlike-p (symbol kind)
 437   (and (eq 'type kind)
 438        (let ((class (find-class symbol nil)))
 439          (some (lambda (type)
 440                  (typep class type))
 441                '(structure-class standard-class sb-pcl::condition-class)))))
 442
 443 (defun def-body (symbol kind docstring)
 444   (with-output-to-string (s)
 445     (when (classlike-p symbol kind)
 446       (format s "Class precedence list: @code{~(~{@w{~A}~^, ~}~)}~%~%"
 447               (remove-if (lambda (super)
 448                            (hidden-superclass-name-p symbol super))
 449                          (mapcar #'class-name
 450                                  (sb-mop:class-precedence-list (find-class symbol)))))
 451       (let ((documented-slots (remove-if (lambda (slot)
 452                                            (hidden-slot-p symbol slot))
 453                                          (sb-mop:class-direct-slots (find-class symbol)))))
 454         (when documented-slots
 455           (format s "Slots:~%@itemize~%")
 456           (dolist (slot documented-slots)
 457             (format s "@item ~(@code{~A} ~@[--- initargs: @code{~{@w{~S}~^, ~}}~]~)~%~%~A~%"
 458                     (sb-mop:slot-definition-name slot)
 459                     (sb-mop:slot-definition-initargs slot)
 460                     (frob-docstring (documentation slot t) nil)))
 461           (format s "@end itemize~%~%"))))
 462     (write-string (frob-docstring docstring (ignore-errors (argument-list symbol))) s)))
 463
 464 (defun def-end (symbol kind)
 465   (declare (ignore symbol))
 466   (ecase kind
 467     ((compiler-macro function method-combination setf) "@end deffn")
 468     ((package variable) "@end defvr")
 469     ((structure type) "@end deftp")))
 470
 471 (defun make-info-file (package &optional filename)
 472   "Create a file containing all available documentation for the
 473   exported symbols of `package' in Texinfo format.  If `filename'
 474   is not supplied, a file \"<packagename>.texinfo\" is generated.
 475
 476   The definitions can be referenced using Texinfo statements like
 477   @ref{<doc-type>_<packagename>_<symbol-name>.texinfo}.  Texinfo
 478   syntax-significant characters are escaped in symbol names, but
 479   if a docstring contains invalid Texinfo markup, you lose."
 480   (let* ((package (find-package package))
 481          (filename (or filename (make-pathname
 482                                  :name (string-downcase (package-name package))
 483                                  :type "texinfo")))
 484          (docs (sort (collect-documentation package) #'string< :key #'first)))
 485     (with-open-file (out filename :direction :output
 486                          :if-does-not-exist :create :if-exists :supersede)
 487       (loop for (symbol kind docstring) in docs
 488            do (write-texinfo out package symbol kind docstring)))
 489     filename))
 490
 491 (defun docstrings-to-texinfo (directory &rest packages)
 492   "Create files in `directory' containing Texinfo markup of all
 493   docstrings of each exported symbol in `packages'.  `directory'
 494   is created if necessary.  If you supply a namestring that
 495   doesn't end in a slash, you lose.  The generated files are of
 496   the form \"<doc-type>_<packagename>_<symbol-name>.texinfo\" and
 497   can be included via @include statements.  Texinfo
 498   syntax-significant characters are escaped in symbol names, but
 499   if a docstring contains invalid Texinfo markup, you lose."
 500   (let ((directory (merge-pathnames (pathname directory))))
 501     (ensure-directories-exist directory)
 502     (dolist (package packages)
 503       (loop
 504          with docs = (collect-documentation (find-package package))
 505          for (symbol kind docstring) in docs
 506          for doc-identifier = (unique-name symbol package kind)
 507          do (with-open-file (out
 508                              (merge-pathnames
 509                               (make-pathname :name doc-identifier :type "texinfo")
 510                               directory)
 511                              :direction :output
 512                              :if-does-not-exist :create :if-exists :supersede)
 513               (write-texinfo out package symbol kind docstring))))
 514     directory))
 515
 516 (defun write-texinfo (stream package symbol kind docstring)
 517   (format stream "~&@anchor{~A}~%~A ~A:~A~@[ ~A~]~%~A~&~A~%~A~%~%"
 518           (unique-name symbol package kind)
 519           (def-begin symbol kind)
 520           (texinfoify (package-name package))
 521           (texinfoify symbol)
 522           (def-arglist symbol kind)
 523           (def-index symbol kind)
 524           (def-body symbol kind docstring)
 525           (def-end symbol kind)))