doc/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 ;;;; This software is part of the SBCL software system. SBCL is in the
   8 ;;;; public domain and is provided with absolutely no warranty. See
   9 ;;;; the COPYING file for more information.
  10 ;;;;
  11 ;;;; Written by Rudi Schlatte <rudi@constantly.at>, mangled
  12 ;;;; by Nikodemus Siivola.
  13
  14 ;;;; TODO
  15 ;;;; * Verbatim text
  16 ;;;; * Quotations
  17 ;;;; * Method documentation untested
  18 ;;;; * Method sorting, somehow
  19 ;;;; * Index for macros & constants?
  20 ;;;; * This is getting complicated enough that tests would be good
  21 ;;;; * Nesting (currently only nested itemizations work)
  22 ;;;; * doc -> internal form -> texinfo (so that non-texinfo format are also
  23 ;;;;   easily generated)
  24
  25 ;;;; FIXME: The description below is no longer complete. This
  26 ;;;; should possibly be turned into a contrib with proper documentation.
  27
  28 ;;;; Formatting heuristics (tweaked to format SAVE-LISP-AND-DIE sanely):
  29 ;;;;
  30 ;;;; Formats SYMBOL as @code{symbol}, or @var{symbol} if symbol is in
  31 ;;;; the argument list of the defun / defmacro.
  32 ;;;;
  33 ;;;; Lines starting with * or - that are followed by intented lines
  34 ;;;; are marked up with @itemize.
  35 ;;;;
  36 ;;;; Lines containing only a SYMBOL that are followed by indented
  37 ;;;; lines are marked up as @table @code, with the SYMBOL as the item.
  38
  39 (eval-when (:compile-toplevel :load-toplevel :execute)
  40   (require 'sb-introspect))
  41
  42 (defpackage :sb-texinfo
  43   (:use :cl :sb-mop)
  44   (:shadow #:documentation)
  45   (:export #:generate-includes #:document-package)
  46   (:documentation
  47    "Tools to generate TexInfo documentation from docstrings."))
  48
  49 (in-package :sb-texinfo)
  50
  51 ;;;; various specials and parameters
  52
  53 (defvar *texinfo-output*)
  54 (defvar *texinfo-variables*)
  55 (defvar *documentation-package*)
  56 (defvar *base-package*)
  57
  58 (defparameter *undocumented-packages* '(sb-pcl sb-int sb-kernel sb-sys sb-c))
  59
  60 (defparameter *documentation-types*
  61   '(compiler-macro
  62     function
  63     method-combination
  64     setf
  65     ;;structure  ; also handled by `type'
  66     type
  67     variable)
  68   "A list of symbols accepted as second argument of `documentation'")
  69
  70 (defparameter *character-replacements*
  71   '((#\* . "star") (#\/ . "slash") (#\+ . "plus")
  72     (#\< . "lt") (#\> . "gt")
  73     (#\= . "equals"))
  74   "Characters and their replacement names that `alphanumize' uses. If
  75 the replacements contain any of the chars they're supposed to replace,
  76 you deserve to lose.")
  77
  78 (defparameter *characters-to-drop* '(#\\ #\` #\')
  79   "Characters that should be removed by `alphanumize'.")
  80
  81 (defparameter *texinfo-escaped-chars* "@{}"
  82   "Characters that must be escaped with #\@ for Texinfo.")
  83
  84 (defparameter *itemize-start-characters* '(#\* #\-)
  85   "Characters that might start an itemization in docstrings when
  86   at the start of a line.")
  87
  88 (defparameter *symbol-characters* "ABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890*:-+&#'"
  89   "List of characters that make up symbols in a docstring.")
  90
  91 (defparameter *symbol-delimiters* " ,.!?;")
  92
  93 (defparameter *ordered-documentation-kinds*
  94   '(package type structure condition class macro))
  95
  96 ;;;; utilities
  97
  98 (defun flatten (list)
  99   (cond ((null list)
 100          nil)
 101         ((consp (car list))
 102          (nconc (flatten (car list)) (flatten (cdr list))))
 103         ((null (cdr list))
 104          (cons (car list) nil))
 105         (t
 106          (cons (car list) (flatten (cdr list))))))
 107
 108 (defun whitespacep (char)
 109   (find char #(#\tab #\space #\page)))
 110
 111 (defun setf-name-p (name)
 112   (or (symbolp name)
 113       (and (listp name) (= 2 (length name)) (eq (car name) 'setf))))
 114
 115 (defgeneric specializer-name (specializer))
 116
 117 (defmethod specializer-name ((specializer eql-specializer))
 118   (list 'eql (eql-specializer-object specializer)))
 119
 120 (defmethod specializer-name ((specializer class))
 121   (class-name specializer))
 122
 123 (defun ensure-class-precedence-list (class)
 124   (unless (class-finalized-p class)
 125     (finalize-inheritance class))
 126   (class-precedence-list class))
 127
 128 (defun specialized-lambda-list (method)
 129   ;; courtecy of AMOP p. 61
 130   (let* ((specializers (method-specializers method))
 131          (lambda-list (method-lambda-list method))
 132          (n-required (length specializers)))
 133     (append (mapcar (lambda (arg specializer)
 134                       (if  (eq specializer (find-class 't))
 135                            arg
 136                            `(,arg ,(specializer-name specializer))))
 137                     (subseq lambda-list 0 n-required)
 138                     specializers)
 139            (subseq lambda-list n-required))))
 140
 141 (defun string-lines (string)
 142   "Lines in STRING as a vector."
 143   (coerce (with-input-from-string (s string)
 144             (loop for line = (read-line s nil nil)
 145                while line collect line))
 146           'vector))
 147
 148 (defun indentation (line)
 149   "Position of first non-SPACE character in LINE."
 150   (position-if-not (lambda (c) (char= c #\Space)) line))
 151
 152 (defun docstring (x doc-type)
 153   (cl:documentation x doc-type))
 154
 155 (defun flatten-to-string (list)
 156   (format nil "~{~A~^-~}" (flatten list)))
 157
 158 (defun alphanumize (original)
 159   "Construct a string without characters like *`' that will f-star-ck
 160 up filename handling. See `*character-replacements*' and
 161 `*characters-to-drop*' for customization."
 162   (let ((name (remove-if (lambda (x) (member x *characters-to-drop*))
 163                          (if (listp original)
 164                              (flatten-to-string original)
 165                              (string original))))
 166         (chars-to-replace (mapcar #'car *character-replacements*)))
 167     (flet ((replacement-delimiter (index)
 168              (cond ((or (< index 0) (>= index (length name))) "")
 169                    ((alphanumericp (char name index)) "-")
 170                    (t ""))))
 171       (loop for index = (position-if #'(lambda (x) (member x chars-to-replace))
 172                                      name)
 173          while index
 174          do (setf name (concatenate 'string (subseq name 0 index)
 175                                     (replacement-delimiter (1- index))
 176                                     (cdr (assoc (aref name index)
 177                                                 *character-replacements*))
 178                                     (replacement-delimiter (1+ index))
 179                                     (subseq name (1+ index))))))
 180     name))
 181
 182 ;;;; generating various names
 183
 184 (defgeneric name (thing)
 185   (:documentation "Name for a documented thing. Names are either
 186 symbols or lists of symbols."))
 187
 188 (defmethod name ((symbol symbol))
 189   symbol)
 190
 191 (defmethod name ((cons cons))
 192   cons)
 193
 194 (defmethod name ((package package))
 195   (short-package-name package))
 196
 197 (defmethod name ((method method))
 198   (list
 199    (generic-function-name (method-generic-function method))
 200    (method-qualifiers method)
 201    (specialized-lambda-list method)))
 202
 203 ;;; Node names for DOCUMENTATION instances
 204
 205 (defgeneric name-using-kind/name (kind name doc))
 206
 207 (defmethod name-using-kind/name (kind (name string) doc)
 208   (declare (ignore kind doc))
 209   name)
 210
 211 (defmethod name-using-kind/name (kind (name symbol) doc)
 212   (declare (ignore kind))
 213   (format nil "~@[~A:~]~A" (short-package-name (get-package doc)) name))
 214
 215 (defmethod name-using-kind/name (kind (name list) doc)
 216   (declare (ignore kind))
 217   (assert (setf-name-p name))
 218   (format nil "(setf ~@[~A:~]~A)" (short-package-name (get-package doc)) (second name)))
 219
 220 (defmethod name-using-kind/name ((kind (eql 'method)) name doc)
 221   (format nil "~A~{ ~A~} ~A"
 222           (name-using-kind/name nil (first name) doc)
 223           (second name)
 224           (third name)))
 225
 226 (defun node-name (doc)
 227   "Returns TexInfo node name as a string for a DOCUMENTATION instance."
 228   (let ((kind (get-kind doc)))
 229     (format nil "~:(~A~) ~(~A~)" kind (name-using-kind/name kind (get-name doc) doc))))
 230
 231 (defun short-package-name (package)
 232   (unless (eq package *base-package*)
 233     (car (sort (copy-list (cons (package-name package) (package-nicknames package)))
 234                #'< :key #'length))))
 235
 236 ;;; Definition titles for DOCUMENTATION instances
 237
 238 (defgeneric title-using-kind/name (kind name doc))
 239
 240 (defmethod title-using-kind/name (kind (name string) doc)
 241   (declare (ignore kind doc))
 242   name)
 243
 244 (defmethod title-using-kind/name (kind (name symbol) doc)
 245   (declare (ignore kind))
 246   (format nil "~@[~A:~]~A" (short-package-name (get-package doc)) name))
 247
 248 (defmethod title-using-kind/name (kind (name list) doc)
 249   (declare (ignore kind))
 250   (assert (setf-name-p name))
 251   (format nil "(setf ~@[~A:~]~A)" (short-package-name (get-package doc)) (second name)))
 252
 253 (defmethod title-using-kind/name ((kind (eql 'method)) name doc)
 254   (format nil "~{~A ~}~A"
 255           (second name)
 256           (title-using-kind/name nil (first name) doc)))
 257
 258 (defun title-name (doc)
 259   "Returns a string to be used as name of the definition."
 260   (string-downcase (title-using-kind/name (get-kind doc) (get-name doc) doc)))
 261
 262 (defun include-pathname (doc)
 263   (let* ((kind (get-kind doc))
 264          (name (nstring-downcase
 265                 (if (eq 'package kind)
 266                     (format nil "package-~A" (alphanumize (get-name doc)))
 267                     (format nil "~A-~A-~A"
 268                             (case (get-kind doc)
 269                               ((function generic-function) "fun")
 270                               (structure "struct")
 271                               (variable "var")
 272                               (otherwise (symbol-name (get-kind doc))))
 273                             (alphanumize (let ((*base-package* nil))
 274                                            (short-package-name (get-package doc))))
 275                             (alphanumize (get-name doc)))))))
 276     (make-pathname :name name  :type "texinfo")))
 277
 278 ;;;; documentation class and related methods
 279
 280 (defclass documentation ()
 281   ((name :initarg :name :reader get-name)
 282    (kind :initarg :kind :reader get-kind)
 283    (string :initarg :string :reader get-string)
 284    (children :initarg :children :initform nil :reader get-children)
 285    (package :initform *documentation-package* :reader get-package)))
 286
 287 (defmethod print-object ((documentation documentation) stream)
 288   (print-unreadable-object (documentation stream :type t)
 289     (princ (list (get-kind documentation) (get-name documentation)) stream)))
 290
 291 (defgeneric make-documentation (x doc-type string))
 292
 293 (defmethod make-documentation ((x package) doc-type string)
 294   (declare (ignore doc-type))
 295   (make-instance 'documentation
 296                  :name (name x)
 297                  :kind 'package
 298                  :string string))
 299
 300 (defmethod make-documentation (x (doc-type (eql 'function)) string)
 301   (declare (ignore doc-type))
 302   (let* ((fdef (and (fboundp x) (fdefinition x)))
 303          (name x)
 304          (kind (cond ((and (symbolp x) (special-operator-p x))
 305                       'special-operator)
 306                      ((and (symbolp x) (macro-function x))
 307                       'macro)
 308                      ((typep fdef 'generic-function)
 309                       (assert (or (symbolp name) (setf-name-p name)))
 310                       'generic-function)
 311                      (fdef
 312                       (assert (or (symbolp name) (setf-name-p name)))
 313                       'function)))
 314          (children (when (eq kind 'generic-function)
 315                      (collect-gf-documentation fdef))))
 316     (make-instance 'documentation
 317                    :name (name x)
 318                    :string string
 319                    :kind kind
 320                    :children children)))
 321
 322 (defmethod make-documentation ((x method) doc-type string)
 323   (declare (ignore doc-type))
 324   (make-instance 'documentation
 325                  :name (name x)
 326                  :kind 'method
 327                  :string string))
 328
 329 (defmethod make-documentation (x (doc-type (eql 'type)) string)
 330   (make-instance 'documentation
 331                  :name (name x)
 332                  :string string
 333                  :kind (etypecase (find-class x nil)
 334                          (structure-class 'structure)
 335                          (standard-class 'class)
 336                          (sb-pcl::condition-class 'condition)
 337                          ((or built-in-class null) 'type))))
 338
 339 (defmethod make-documentation (x (doc-type (eql 'variable)) string)
 340   (make-instance 'documentation
 341                  :name (name x)
 342                  :string string
 343                  :kind (if (constantp x)
 344                            'constant
 345                            'variable)))
 346
 347 (defmethod make-documentation (x (doc-type (eql 'setf)) string)
 348   (declare (ignore doc-type))
 349   (make-instance 'documentation
 350                  :name (name x)
 351                  :kind 'setf-expander
 352                  :string string))
 353
 354 (defmethod make-documentation (x doc-type string)
 355   (make-instance 'documentation
 356                  :name (name x)
 357                  :kind doc-type
 358                  :string string))
 359
 360 (defun maybe-documentation (x doc-type)
 361   "Returns a DOCUMENTATION instance for X and DOC-TYPE, or NIL if
 362 there is no corresponding docstring."
 363   (let ((docstring (docstring x doc-type)))
 364     (when docstring
 365       (make-documentation x doc-type docstring))))
 366
 367 (defun lambda-list (doc)
 368   (case (get-kind doc)
 369     ((package constant variable type structure class condition nil)
 370      nil)
 371     (method
 372      (third (get-name doc)))
 373     (t
 374      ;; KLUDGE: Eugh.
 375      ;;
 376      ;; believe it or not, the above comment was written before CSR
 377      ;; came along and obfuscated this.  (2005-07-04)
 378      (when (symbolp (get-name doc))
 379        (labels ((clean (x &key optional key)
 380                   (typecase x
 381                     (atom x)
 382                     ((cons (member &optional))
 383                      (cons (car x) (clean (cdr x) :optional t)))
 384                     ((cons (member &key))
 385                      (cons (car x) (clean (cdr x) :key t)))
 386                     ((cons (member &whole &environment))
 387                      ;; Skip these
 388                      (clean (cdr x) :optional optional :key key))
 389                     ((cons cons)
 390                      (cons
 391                       (cond (key (if (consp (caar x))
 392                                      (caaar x)
 393                                      (caar x)))
 394                             (optional (caar x))
 395                             (t (clean (car x))))
 396                       (clean (cdr x) :key key :optional optional)))
 397                     (cons
 398                      (cons
 399                       (cond ((or key optional) (car x))
 400                             (t (clean (car x))))
 401                       (clean (cdr x) :key key :optional optional))))))
 402          (clean (sb-introspect:function-lambda-list (get-name doc))))))))
 403
 404 (defun get-string-name (x)
 405   (let ((name (get-name x)))
 406     (cond ((symbolp name)
 407            (symbol-name name))
 408           ((and (consp name) (eq 'setf (car name)))
 409            (symbol-name (second name)))
 410           ((stringp name)
 411            name)
 412           (t
 413            (error "Don't know which symbol to use for name ~S" name)))))
 414
 415 (defun documentation< (x y)
 416   (let ((p1 (position (get-kind x) *ordered-documentation-kinds*))
 417         (p2 (position (get-kind y) *ordered-documentation-kinds*)))
 418     (if (or (not (and p1 p2)) (= p1 p2))
 419         (string< (get-string-name x) (get-string-name y))
 420         (< p1 p2))))
 421
 422 ;;;; turning text into texinfo
 423
 424 (defun escape-for-texinfo (string &optional downcasep)
 425   "Return STRING with characters in *TEXINFO-ESCAPED-CHARS* escaped
 426 with #\@. Optionally downcase the result."
 427   (let ((result (with-output-to-string (s)
 428                   (loop for char across string
 429                         when (find char *texinfo-escaped-chars*)
 430                         do (write-char #\@ s)
 431                         do (write-char char s)))))
 432     (if downcasep (nstring-downcase result) result)))
 433
 434 (defun empty-p (line-number lines)
 435   (and (< -1 line-number (length lines))
 436        (not (indentation (svref lines line-number)))))
 437
 438 ;;; line markups
 439
 440 (defvar *not-symbols* '("ANSI" "CLHS"))
 441
 442 (defun locate-symbols (line)
 443   "Return a list of index pairs of symbol-like parts of LINE."
 444   ;; This would be a good application for a regex ...
 445   (let (result)
 446     (flet ((grab (start end)
 447              (unless (member (subseq line start end) '("ANSI" "CLHS"))
 448                (push (list start end) result))))
 449       (do ((begin nil)
 450            (maybe-begin t)
 451            (i 0 (1+ i)))
 452           ((= i (length line))
 453            ;; symbol at end of line
 454            (when (and begin (or (> i (1+ begin))
 455                                 (not (member (char line begin) '(#\A #\I)))))
 456              (grab begin i))
 457            (nreverse result))
 458         (cond
 459           ((and begin (find (char line i) *symbol-delimiters*))
 460            ;; symbol end; remember it if it's not "A" or "I"
 461            (when (or (> i (1+ begin)) (not (member (char line begin) '(#\A #\I))))
 462              (grab begin i))
 463            (setf begin nil
 464                  maybe-begin t))
 465           ((and begin (not (find (char line i) *symbol-characters*)))
 466            ;; Not a symbol: abort
 467            (setf begin nil))
 468           ((and maybe-begin (not begin) (find (char line i) *symbol-characters*))
 469            ;; potential symbol begin at this position
 470            (setf begin i
 471                  maybe-begin nil))
 472           ((find (char line i) *symbol-delimiters*)
 473            ;; potential symbol begin after this position
 474            (setf maybe-begin t))
 475           (t
 476            ;; Not reading a symbol, not at potential start of symbol
 477            (setf maybe-begin nil)))))))
 478
 479 (defun texinfo-line (line)
 480   "Format symbols in LINE texinfo-style: either as code or as
 481 variables if the symbol in question is contained in symbols
 482 *TEXINFO-VARIABLES*."
 483   (with-output-to-string (result)
 484     (let ((last 0))
 485       (dolist (symbol/index (locate-symbols line))
 486         (write-string (subseq line last (first symbol/index)) result)
 487         (let ((symbol-name (apply #'subseq line symbol/index)))
 488           (format result (if (member symbol-name *texinfo-variables*
 489                                      :test #'string=)
 490                              "@var{~A}"
 491                              "@code{~A}")
 492                   (string-downcase symbol-name)))
 493         (setf last (second symbol/index)))
 494       (write-string (subseq line last) result))))
 495
 496 ;;; lisp sections
 497
 498 (defun lisp-section-p (line line-number lines)
 499   "Returns T if the given LINE looks like start of lisp code --
 500 ie. if it starts with whitespace followed by a paren or
 501 semicolon, and the previous line is empty"
 502   (let ((offset (indentation line)))
 503     (and offset
 504          (plusp offset)
 505          (find (find-if-not #'whitespacep line) "(;")
 506          (empty-p (1- line-number) lines))))
 507
 508 (defun collect-lisp-section (lines line-number)
 509   (let ((lisp (loop for index = line-number then (1+ index)
 510                     for line = (and (< index (length lines)) (svref lines index))
 511                     while (indentation line)
 512                     collect line)))
 513     (values (length lisp) `("@lisp" ,@lisp "@end lisp"))))
 514
 515 ;;; itemized sections
 516
 517 (defun maybe-itemize-offset (line)
 518   "Return NIL or the indentation offset if LINE looks like it starts
 519 an item in an itemization."
 520   (let* ((offset (indentation line))
 521          (char (when offset (char line offset))))
 522     (and offset
 523          (member char *itemize-start-characters* :test #'char=)
 524          (char= #\Space (find-if-not (lambda (c) (char= c char))
 525                                      line :start offset))
 526          offset)))
 527
 528 (defun collect-maybe-itemized-section (lines starting-line)
 529   ;; Return index of next line to be processed outside
 530   (let ((this-offset (maybe-itemize-offset (svref lines starting-line)))
 531         (result nil)
 532         (lines-consumed 0))
 533     (loop for line-number from starting-line below (length lines)
 534        for line = (svref lines line-number)
 535        for indentation = (indentation line)
 536        for offset = (maybe-itemize-offset line)
 537        do (cond
 538             ((not indentation)
 539              ;; empty line -- inserts paragraph.
 540              (push "" result)
 541              (incf lines-consumed))
 542             ((and offset (> indentation this-offset))
 543              ;; nested itemization -- handle recursively
 544              ;; FIXME: tables in itemizations go wrong
 545              (multiple-value-bind (sub-lines-consumed sub-itemization)
 546                  (collect-maybe-itemized-section lines line-number)
 547                (when sub-lines-consumed
 548                  (incf line-number (1- sub-lines-consumed)) ; +1 on next loop
 549                  (incf lines-consumed sub-lines-consumed)
 550                  (setf result (nconc (nreverse sub-itemization) result)))))
 551             ((and offset (= indentation this-offset))
 552              ;; start of new item
 553              (push (format nil "@item ~A"
 554                            (texinfo-line (subseq line (1+ offset))))
 555                    result)
 556              (incf lines-consumed))
 557             ((and (not offset) (> indentation this-offset))
 558              ;; continued item from previous line
 559              (push (texinfo-line line) result)
 560              (incf lines-consumed))
 561             (t
 562              ;; end of itemization
 563              (loop-finish))))
 564     ;; a single-line itemization isn't.
 565     (if (> (count-if (lambda (line) (> (length line) 0)) result) 1)
 566         (values lines-consumed `("@itemize" ,@(reverse result) "@end itemize"))
 567         nil)))
 568
 569 ;;; table sections
 570
 571 (defun tabulation-body-p (offset line-number lines)
 572   (when (< line-number (length lines))
 573     (let ((offset2 (indentation (svref lines line-number))))
 574       (and offset2 (< offset offset2)))))
 575
 576 (defun tabulation-p (offset line-number lines direction)
 577   (let ((step  (ecase direction
 578                  (:backwards (1- line-number))
 579                  (:forwards (1+ line-number)))))
 580     (when (and (plusp line-number) (< line-number (length lines)))
 581       (and (eql offset (indentation (svref lines line-number)))
 582            (or (when (eq direction :backwards)
 583                  (empty-p step lines))
 584                (tabulation-p offset step lines direction)
 585                (tabulation-body-p offset step lines))))))
 586
 587 (defun maybe-table-offset (line-number lines)
 588   "Return NIL or the indentation offset if LINE looks like it starts
 589 an item in a tabulation. Ie, if it is (1) indented, (2) preceded by an
 590 empty line, another tabulation label, or a tabulation body, (3) and
 591 followed another tabulation label or a tabulation body."
 592   (let* ((line (svref lines line-number))
 593          (offset (indentation line))
 594          (prev (1- line-number))
 595          (next (1+ line-number)))
 596     (when (and offset (plusp offset))
 597       (and (or (empty-p prev lines)
 598                (tabulation-body-p offset prev lines)
 599                (tabulation-p offset prev lines :backwards))
 600            (or (tabulation-body-p offset next lines)
 601                (tabulation-p offset next lines :forwards))
 602            offset))))
 603
 604 ;;; FIXME: This and itemization are very similar: could they share
 605 ;;; some code, mayhap?
 606
 607 (defun collect-maybe-table-section (lines starting-line)
 608   ;; Return index of next line to be processed outside
 609   (let ((this-offset (maybe-table-offset starting-line lines))
 610         (result nil)
 611         (lines-consumed 0))
 612     (loop for line-number from starting-line below (length lines)
 613           for line = (svref lines line-number)
 614           for indentation = (indentation line)
 615           for offset = (maybe-table-offset line-number lines)
 616           do (cond
 617                ((not indentation)
 618                 ;; empty line -- inserts paragraph.
 619                 (push "" result)
 620                 (incf lines-consumed))
 621                ((and offset (= indentation this-offset))
 622                 ;; start of new item, or continuation of previous item
 623                 (if (and result (search "@item" (car result) :test #'char=))
 624                     (push (format nil "@itemx ~A" (texinfo-line line))
 625                           result)
 626                     (progn
 627                       (push "" result)
 628                       (push (format nil "@item ~A" (texinfo-line line))
 629                             result)))
 630                 (incf lines-consumed))
 631                ((> indentation this-offset)
 632                 ;; continued item from previous line
 633                 (push (texinfo-line line) result)
 634                 (incf lines-consumed))
 635                (t
 636                 ;; end of itemization
 637                 (loop-finish))))
 638      ;; a single-line table isn't.
 639     (if (> (count-if (lambda (line) (> (length line) 0)) result) 1)
 640         (values lines-consumed
 641                 `("" "@table @emph" ,@(reverse result) "@end table" ""))
 642         nil)))
 643
 644 ;;; section markup
 645
 646 (defmacro with-maybe-section (index &rest forms)
 647   `(multiple-value-bind (count collected) (progn ,@forms)
 648     (when count
 649       (dolist (line collected)
 650         (write-line line *texinfo-output*))
 651       (incf ,index (1- count)))))
 652
 653 (defun write-texinfo-string (string &optional lambda-list)
 654   "Try to guess as much formatting for a raw docstring as possible."
 655   (let ((*texinfo-variables* (flatten lambda-list))
 656         (lines (string-lines (escape-for-texinfo string nil))))
 657       (loop for line-number from 0 below (length lines)
 658             for line = (svref lines line-number)
 659             do (cond
 660                  ((with-maybe-section line-number
 661                     (and (lisp-section-p line line-number lines)
 662                          (collect-lisp-section lines line-number))))
 663                  ((with-maybe-section line-number
 664                     (and (maybe-itemize-offset line)
 665                          (collect-maybe-itemized-section lines line-number))))
 666                  ((with-maybe-section line-number
 667                     (and (maybe-table-offset line-number lines)
 668                          (collect-maybe-table-section lines line-number))))
 669                  (t
 670                   (write-line (texinfo-line line) *texinfo-output*))))))
 671
 672 ;;;; texinfo formatting tools
 673
 674 (defun hide-superclass-p (class-name super-name)
 675   (let ((super-package (symbol-package super-name)))
 676     (or
 677      ;; KLUDGE: We assume that we don't want to advertise internal
 678      ;; classes in CP-lists, unless the symbol we're documenting is
 679      ;; internal as well.
 680      (and (member super-package #.'(mapcar #'find-package *undocumented-packages*))
 681           (not (eq super-package (symbol-package class-name))))
 682      ;; KLUDGE: We don't generally want to advertise SIMPLE-ERROR or
 683      ;; SIMPLE-CONDITION in the CPLs of conditions that inherit them
 684      ;; simply as a matter of convenience. The assumption here is that
 685      ;; the inheritance is incidental unless the name of the condition
 686      ;; begins with SIMPLE-.
 687      (and (member super-name '(simple-error simple-condition))
 688           (let ((prefix "SIMPLE-"))
 689             (mismatch prefix (string class-name) :end2 (length prefix)))
 690           t ; don't return number from MISMATCH
 691           ))))
 692
 693 (defun hide-slot-p (symbol slot)
 694   ;; FIXME: There is no pricipal reason to avoid the slot docs fo
 695   ;; structures and conditions, but their DOCUMENTATION T doesn't
 696   ;; currently work with them the way we'd like.
 697   (not (and (typep (find-class symbol nil) 'standard-class)
 698             (docstring slot t))))
 699
 700 (defun texinfo-anchor (doc)
 701   (format *texinfo-output* "@anchor{~A}~%" (node-name doc)))
 702
 703 ;;; KLUDGE: &AUX *PRINT-PRETTY* here means "no linebreaks please"
 704 (defun texinfo-begin (doc &aux *print-pretty*)
 705   (let ((kind (get-kind doc)))
 706     (format *texinfo-output* "@~A {~:(~A~)} ~({~A}~@[ ~{~A~^ ~}~]~)~%"
 707             (case kind
 708               ((package constant variable)
 709                "defvr")
 710               ((structure class condition type)
 711                "deftp")
 712               (t
 713                "deffn"))
 714             (map 'string (lambda (char) (if (eql char #\-) #\Space char)) (string kind))
 715             (title-name doc)
 716             ;; &foo would be amusingly bold in the pdf thanks to TeX/Texinfo
 717             ;; interactions,so we escape the ampersand -- amusingly for TeX.
 718             ;; sbcl.texinfo defines macros that expand @&key and friends to &key.
 719             (mapcar (lambda (name)
 720                       (if (member name lambda-list-keywords)
 721                           (format nil "@~A" name)
 722                           name))
 723                     (lambda-list doc)))))
 724
 725 (defun texinfo-index (doc)
 726   (let ((title (title-name doc)))
 727     (case (get-kind doc)
 728       ((structure type class condition)
 729        (format *texinfo-output* "@tindex ~A~%" title))
 730       ((variable constant)
 731        (format *texinfo-output* "@vindex ~A~%" title))
 732       ((compiler-macro function method-combination macro generic-function)
 733        (format *texinfo-output* "@findex ~A~%" title)))))
 734
 735 (defun texinfo-inferred-body (doc)
 736   (when (member (get-kind doc) '(class structure condition))
 737     (let ((name (get-name doc)))
 738       ;; class precedence list
 739       (format *texinfo-output* "Class precedence list: @code{~(~{@lw{~A}~^, ~}~)}~%~%"
 740               (remove-if (lambda (class)  (hide-superclass-p name class))
 741                          (mapcar #'class-name (ensure-class-precedence-list (find-class name)))))
 742       ;; slots
 743       (let ((slots (remove-if (lambda (slot) (hide-slot-p name slot))
 744                               (class-direct-slots (find-class name)))))
 745         (when slots
 746           (format *texinfo-output* "Slots:~%@itemize~%")
 747           (dolist (slot slots)
 748             (format *texinfo-output*
 749                     "@item ~(@code{~A}~#[~:; --- ~]~
 750                       ~:{~2*~@[~2:*~A~P: ~{@code{@w{~S}}~^, ~}~]~:^; ~}~)~%~%"
 751                     (slot-definition-name slot)
 752                     (remove
 753                      nil
 754                      (mapcar
 755                       (lambda (name things)
 756                         (if things
 757                             (list name (length things) things)))
 758                       '("initarg" "reader"  "writer")
 759                       (list
 760                        (slot-definition-initargs slot)
 761                        (slot-definition-readers slot)
 762                        (slot-definition-writers slot)))))
 763             ;; FIXME: Would be neater to handler as children
 764             (write-texinfo-string (docstring slot t)))
 765           (format *texinfo-output* "@end itemize~%~%"))))))
 766
 767 (defun texinfo-body (doc)
 768   (write-texinfo-string (get-string doc)))
 769
 770 (defun texinfo-end (doc)
 771   (write-line (case (get-kind doc)
 772                 ((package variable constant) "@end defvr")
 773                 ((structure type class condition) "@end deftp")
 774                 (t "@end deffn"))
 775               *texinfo-output*))
 776
 777 (defun write-texinfo (doc)
 778   "Writes TexInfo for a DOCUMENTATION instance to *TEXINFO-OUTPUT*."
 779   (texinfo-anchor doc)
 780   (texinfo-begin doc)
 781   (texinfo-index doc)
 782   (texinfo-inferred-body doc)
 783   (texinfo-body doc)
 784   (texinfo-end doc)
 785   ;; FIXME: Children should be sorted one way or another
 786   (mapc #'write-texinfo (get-children doc)))
 787
 788 ;;;; main logic
 789
 790 (defun collect-gf-documentation (gf)
 791   "Collects method documentation for the generic function GF"
 792   (loop for method in (generic-function-methods gf)
 793         for doc = (maybe-documentation method t)
 794         when doc
 795         collect doc))
 796
 797 (defun collect-name-documentation (name)
 798   (loop for type in *documentation-types*
 799         for doc = (maybe-documentation name type)
 800         when doc
 801         collect doc))
 802
 803 (defun collect-symbol-documentation (symbol)
 804   "Collects all docs for a SYMBOL and (SETF SYMBOL), returns a list of
 805 the form DOC instances. See `*documentation-types*' for the possible
 806 values of doc-type."
 807   (nconc (collect-name-documentation symbol)
 808          (collect-name-documentation (list 'setf symbol))))
 809
 810 (defun collect-documentation (package)
 811   "Collects all documentation for all external symbols of the given
 812 package, as well as for the package itself."
 813   (let* ((*documentation-package* (find-package package))
 814          (docs nil))
 815     (check-type package package)
 816     (do-external-symbols (symbol package)
 817       (setf docs (nconc (collect-symbol-documentation symbol) docs)))
 818     (let ((doc (maybe-documentation *documentation-package* t)))
 819       (when doc
 820         (push doc docs)))
 821     docs))
 822
 823 (defmacro with-texinfo-file (pathname &body forms)
 824   `(with-open-file (*texinfo-output* ,pathname
 825                                     :direction :output
 826                                     :if-does-not-exist :create
 827                                     :if-exists :supersede)
 828     ,@forms))
 829
 830 (defun write-ifnottex ()
 831   ;; We use @&key, etc to escape & from TeX in lambda lists -- so we need to
 832   ;; define them for info as well.
 833   (flet ((macro (name)
 834                  (let ((string (string-downcase name)))
 835                    (format *texinfo-output* "@macro ~A~%~A~%@end macro~%" string string))))
 836     (macro '&allow-other-keys)
 837     (macro '&optional)
 838     (macro '&rest)
 839     (macro '&key)
 840     (macro '&body)))
 841
 842 (defun generate-includes (directory packages &key (base-package :cl-user))
 843   "Create files in `directory' containing Texinfo markup of all
 844 docstrings of each exported symbol in `packages'. `directory' is
 845 created if necessary. If you supply a namestring that doesn't end in a
 846 slash, you lose. The generated files are of the form
 847 \"<doc-type>_<packagename>_<symbol-name>.texinfo\" and can be included
 848 via @include statements. Texinfo syntax-significant characters are
 849 escaped in symbol names, but if a docstring contains invalid Texinfo
 850 markup, you lose."
 851   (handler-bind ((warning #'muffle-warning))
 852     (let ((directory (merge-pathnames (pathname directory)))
 853           (*base-package* (find-package base-package)))
 854       (ensure-directories-exist directory)
 855       (dolist (package packages)
 856         (dolist (doc (collect-documentation (find-package package)))
 857           (with-texinfo-file (merge-pathnames (include-pathname doc) directory)
 858             (write-texinfo doc))))
 859       (with-texinfo-file (merge-pathnames "ifnottex.texinfo" directory)
 860         (write-ifnottex))
 861       directory)))
 862
 863 (defun document-package (package &optional filename)
 864   "Create a file containing all available documentation for the
 865 exported symbols of `package' in Texinfo format. If `filename' is not
 866 supplied, a file \"<packagename>.texinfo\" is generated.
 867
 868 The definitions can be referenced using Texinfo statements like
 869 @ref{<doc-type>_<packagename>_<symbol-name>.texinfo}. Texinfo
 870 syntax-significant characters are escaped in symbol names, but if a
 871 docstring contains invalid Texinfo markup, you lose."
 872   (handler-bind ((warning #'muffle-warning))
 873     (let* ((package (find-package package))
 874            (filename (or filename (make-pathname
 875                                    :name (string-downcase (short-package-name package))
 876                                    :type "texinfo")))
 877            (docs (sort (collect-documentation package) #'documentation<)))
 878       (with-texinfo-file filename
 879         (dolist (doc docs)
 880           (write-texinfo doc)))
 881       filename)))