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
 221 (defun collect-maybe-table-section (lines starting-line arglist-symbols)
 222   ;; Return index of next line to be processed outside
 223   (let ((this-offset (maybe-table-offset (svref lines starting-line)))
 224         (result nil)
 225         (lines-consumed 0))
 226     (loop for line-number from starting-line below (length lines)
 227        for line = (svref lines line-number)
 228        for indentation = (indentation line)
 229        for offset = (maybe-table-offset line)
 230        do (cond
 231             ((not indentation)
 232              ;; empty line -- inserts paragraph.
 233              (push "" result)
 234              (incf lines-consumed))
 235             ((and offset (= indentation this-offset))
 236              ;; start of new item, or continuation of previous item
 237              (if (and result (search "@item" (car result) :test #'char=))
 238                  (push (format nil "@itemx ~A"
 239                                (frob-doc-line line arglist-symbols))
 240                        result)
 241                  (progn
 242                    (push "" result)
 243                    (push (format nil "@item ~A"
 244                                  (frob-doc-line line arglist-symbols))
 245                          result)))
 246              (incf lines-consumed))
 247             ((> indentation this-offset)
 248              ;; continued item from previous line
 249              (push (frob-doc-line line arglist-symbols) result)
 250              (incf lines-consumed))
 251             (t
 252              ;; end of itemization
 253              (loop-finish))))
 254     (if
 255      ;; a single-line table isn't.
 256      (> (count-if (lambda (line) (> (length line) 0)) result) 1)
 257      (values lines-consumed
 258              `("" "@table @code" ,@(reverse result) "@end table" ""))
 259      nil)))
 260
 261
 262
 263
 264 (defun string-as-lines (string)
 265   (coerce (with-input-from-string (s string)
 266             (loop for line = (read-line s nil nil)
 267                while line collect line))
 268           'vector))
 269
 270 (defun frob-docstring (docstring symbol-arglist)
 271   "Try to guess as much formatting for a raw docstring as possible."
 272   ;; Per-line processing is not necessary now, but it will be when we
 273   ;; attempt itemize / table auto-detection in docstrings
 274   (with-output-to-string (result)
 275     (let ((arglist-symbols (all-symbols symbol-arglist))
 276           (doc-lines (string-as-lines (texinfoify docstring nil))))
 277       (loop for line-number from 0 below (length doc-lines)
 278            for line = (svref doc-lines line-number)
 279          do (cond
 280               ((maybe-itemize-offset line)
 281                (multiple-value-bind (lines-consumed itemized-lines)
 282                    (collect-maybe-itemized-section doc-lines line-number
 283                                                    arglist-symbols)
 284                  (cond (lines-consumed
 285                         (dolist (item-line itemized-lines)
 286                           (write-line item-line result))
 287                         (incf line-number (1- lines-consumed)))
 288                        (t (write-line (frob-doc-line line arglist-symbols)
 289                              result)))))
 290               ((maybe-table-offset line)
 291                (multiple-value-bind (lines-consumed itemized-lines)
 292                    (collect-maybe-table-section doc-lines line-number
 293                                                    arglist-symbols)
 294                  (cond (lines-consumed
 295                         (dolist (item-line itemized-lines)
 296                           (write-line item-line result))
 297                         (incf line-number (1- lines-consumed)))
 298                        (t (write-line (frob-doc-line line arglist-symbols)
 299                              result)))))
 300               (t (write-line (frob-doc-line line arglist-symbols) result)))))))
 301
 302 ;;; Begin, rest and end of definition.
 303
 304 (defun argument-list (fname)
 305   (sb-introspect:function-arglist fname))
 306
 307 (defvar *character-replacements*
 308   '((#\* . "star") (#\/ . "slash") (#\+ . "plus"))
 309   "Characters and their replacement names that `alphanumize'
 310   uses.  If the replacements contain any of the chars they're
 311   supposed to replace, you deserve to lose.")
 312
 313 (defvar *characters-to-drop* '(#\\ #\` #\')
 314   "Characters that should be removed by `alphanumize'.")
 315
 316
 317 (defun alphanumize (symbol)
 318   "Construct a string without characters like *`' that will
 319   f-star-ck up filename handling.  See `*character-replacements*'
 320   and `*characters-to-drop*' for customization."
 321   (let ((name (remove-if #'(lambda (x) (member x *characters-to-drop*))
 322                          (string symbol)))
 323         (chars-to-replace (mapcar #'car *character-replacements*)))
 324     (flet ((replacement-delimiter (index)
 325              (cond ((or (< index 0) (>= index (length name))) "")
 326                    ((alphanumericp (char name index)) "-")
 327                    (t ""))))
 328       (loop for index = (position-if #'(lambda (x) (member x chars-to-replace))
 329                                      name)
 330          while index
 331          do (setf name (concatenate 'string (subseq name 0 index)
 332                                     (replacement-delimiter (1- index))
 333                                     (cdr (assoc (aref name index)
 334                                                 *character-replacements*))
 335                                     (replacement-delimiter (1+ index))
 336                                     (subseq name (1+ index))))))
 337     name))
 338
 339 (defun unique-name (symbol package kind)
 340   (nstring-downcase
 341    (format nil "~A-~A-~A"
 342            (ecase kind
 343              (compiler-macro "compiler-macro")
 344              (function (cond
 345                          ((macro-function symbol) "macro")
 346                          ((special-operator-p symbol) "special-operator")
 347                          (t "fun")))
 348              (method-combination "method-combination")
 349              (package "package")
 350              (setf "setf-expander")
 351              (structure "struct")
 352              (type (let ((class (find-class symbol nil)))
 353                      (etypecase class
 354                        (structure-class "struct")
 355                        (standard-class "class")
 356                        (sb-pcl::condition-class "condition")
 357                        ((or built-in-class null) "type"))))
 358              (variable (if (constantp symbol)
 359                            "constant"
 360                            "var")))
 361            (package-name package)
 362            (alphanumize symbol))))
 363
 364 (defun def-begin (symbol kind)
 365   (ecase kind
 366     (compiler-macro "@deffn {Compiler Macro}")
 367     (function (cond
 368                 ((macro-function symbol) "@deffn Macro")
 369                 ((special-operator-p symbol) "@deffn {Special Operator}")
 370                 (t "@deffn Function")))
 371     (method-combination "@deffn {Method Combination}")
 372     (package "@defvr Package")
 373     (setf "@deffn {Setf Expander}")
 374     (structure "@deftp Structure")
 375     (type (let ((class (find-class symbol nil)))
 376             (etypecase class
 377               (structure-class "@deftp Structure")
 378               (standard-class "@deftp Class")
 379               (sb-pcl::condition-class "@deftp Condition")
 380               ((or built-in-class null) "@deftp Type"))))
 381     (variable (if (constantp symbol)
 382                   "@defvr Constant"
 383                   "@defvr Variable"))))
 384
 385 (defun def-index (symbol kind)
 386   (case kind
 387     ((compiler-macro function method-combination)
 388      (format nil "@findex ~A" (texinfoify symbol)))
 389     ((structure type)
 390      (format nil "@tindex ~A" (texinfoify symbol)))
 391     (variable
 392      (format nil "@vindex ~A" (texinfoify symbol)))))
 393
 394 (defparameter *arglist-keywords*
 395   '(&allow-other-keys &aux &body &environment &key &optional &rest &whole))
 396
 397 (defun texinfoify-arglist-part (part)
 398   (with-output-to-string (s)
 399     (etypecase part
 400       (string (prin1 (texinfoify part nil) s))
 401       (number (prin1 part s))
 402       (symbol
 403        (if (member part *arglist-keywords*)
 404            (princ (texinfoify part) s)
 405            (format s "@var{~A}" (texinfoify part))))
 406       (list
 407        (format s "(~{~A~^ ~})" (mapcar #'texinfoify-arglist-part part))))))
 408
 409 (defun def-arglist (symbol kind)
 410   (case kind
 411     (function
 412      (format nil "~{~A~^ ~}"
 413              (mapcar #'texinfoify-arglist-part (argument-list symbol))))))
 414
 415 (defun def-end (symbol kind)
 416   (declare (ignore symbol))
 417   (ecase kind
 418     ((compiler-macro function method-combination setf) "@end deffn")
 419     ((package variable) "@end defvr")
 420     ((structure type) "@end deftp")))
 421
 422 (defun make-info-file (package &optional filename)
 423   "Create a file containing all available documentation for the
 424   exported symbols of `package' in Texinfo format.  If `filename'
 425   is not supplied, a file \"<packagename>.texinfo\" is generated.
 426
 427   The definitions can be referenced using Texinfo statements like
 428   @ref{<doc-type>_<packagename>_<symbol-name>.texinfo}.  Texinfo
 429   syntax-significant characters are escaped in symbol names, but
 430   if a docstring contains invalid Texinfo markup, you lose."
 431   (let* ((package (find-package package))
 432          (filename (or filename (make-pathname
 433                                  :name (string-downcase (package-name package))
 434                                  :type "texinfo")))
 435          (docs (sort (collect-documentation package) #'string< :key #'first)))
 436     (with-open-file (out filename :direction :output
 437                          :if-does-not-exist :create :if-exists :supersede)
 438       (loop for (symbol kind docstring) in docs
 439            do (format out "~&@anchor{~A}~%~A ~A:~A~@[ ~A~]~%~A~&~A~%~A~%~%"
 440                       (unique-name symbol package kind)
 441                       (def-begin symbol kind)
 442                       (texinfoify (package-name package))
 443                       (texinfoify symbol)
 444                       (def-arglist symbol kind)
 445                       (def-index symbol kind)
 446                       (frob-docstring docstring (argument-list symbol))
 447                       (def-end symbol kind))))
 448     filename))
 449
 450 (defun docstrings-to-texinfo (directory &rest packages)
 451   "Create files in `directory' containing Texinfo markup of all
 452   docstrings of each exported symbol in `packages'.  `directory'
 453   is created if necessary.  If you supply a namestring that
 454   doesn't end in a slash, you lose.  The generated files are of
 455   the form \"<doc-type>_<packagename>_<symbol-name>.texinfo\" and
 456   can be included via @include statements.  Texinfo
 457   syntax-significant characters are escaped in symbol names, but
 458   if a docstring contains invalid Texinfo markup, you lose."
 459   (let ((directory (merge-pathnames (pathname directory))))
 460     (ensure-directories-exist directory)
 461     (dolist (package packages)
 462       (loop
 463          with docs = (collect-documentation (find-package package))
 464          for (symbol kind docstring) in docs
 465          for doc-identifier = (unique-name symbol package kind)
 466          do (with-open-file (out
 467                              (merge-pathnames
 468                               (make-pathname :name doc-identifier :type "texinfo")
 469                               directory)
 470                              :direction :output
 471                              :if-does-not-exist :create :if-exists :supersede)
 472               (format out "~&@anchor{~A}~%~A ~A:~A~@[ ~A~]~%~A~&~A~%~A~%~%"
 473                       (unique-name symbol package kind)
 474                       (def-begin symbol kind)
 475                       (texinfoify (package-name package))
 476                       (texinfoify symbol)
 477                       (def-arglist symbol kind)
 478                       (def-index symbol kind)
 479                       (frob-docstring docstring (ignore-errors (argument-list symbol)))
 480                       (def-end symbol kind)))))
 481     directory))