3rdparties/software/alexandria-20200427-git/doc/docstrings.lisp (35547 bytes)
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 (defun short-name-for-symbol (symbol &optional (package *base-package*)) 206 "Given a SYMBOL, return its name if it's available in PACKAGE, 207 or PACKAGE:SYMBOL otherwise." 208 (format nil "~@[~a:~]~a" 209 (unless (eq symbol 210 (find-symbol (symbol-name symbol) 211 package)) 212 (shortest-package-name (symbol-package symbol))) 213 (symbol-name symbol))) 214 215 (defgeneric name-using-kind/name (kind name doc)) 216 217 (defmethod name-using-kind/name (kind (name string) doc) 218 (declare (ignore kind doc)) 219 name) 220 221 (defmethod name-using-kind/name (kind (name symbol) doc) 222 (declare (ignore kind)) 223 (short-name-for-symbol name)) 224 225 (defmethod name-using-kind/name (kind (name list) doc) 226 (declare (ignore kind)) 227 (assert (setf-name-p name)) 228 (let ((name (short-name-for-symbol (second name)))) 229 (format nil "(setf ~A)" name))) 230 231 (defmethod name-using-kind/name ((kind (eql 'method)) name doc) 232 (format nil "~A~{ ~A~} ~A" 233 (name-using-kind/name nil (first name) doc) 234 (second name) 235 (third name))) 236 237 (defun node-name (doc) 238 "Returns TexInfo node name as a string for a DOCUMENTATION instance." 239 (let ((kind (get-kind doc))) 240 (format nil "~:(~A~) ~(~A~)" kind (name-using-kind/name kind (get-name doc) doc)))) 241 242 (defun shortest-package-name (package) 243 (car (sort (copy-list (cons (package-name package) (package-nicknames package))) 244 #'< :key #'length))) 245 246 (defun short-package-name (package) 247 (unless (eq package *base-package*) 248 (shortest-package-name package))) 249 250 251 ;;; Definition titles for DOCUMENTATION instances 252 253 (defgeneric title-using-kind/name (kind name doc)) 254 255 (defmethod title-using-kind/name (kind (name string) doc) 256 (declare (ignore kind doc)) 257 name) 258 259 (defmethod title-using-kind/name (kind (name symbol) doc) 260 (declare (ignore kind)) 261 (short-name-for-symbol name)) 262 263 (defmethod title-using-kind/name (kind (name list) doc) 264 (declare (ignore kind)) 265 (assert (setf-name-p name)) 266 (format nil "(setf ~A)" (short-name-for-symbol (second name)))) 267 268 (defmethod title-using-kind/name ((kind (eql 'method)) name doc) 269 (format nil "~{~A ~}~A" 270 (second name) 271 (title-using-kind/name nil (first name) doc))) 272 273 (defun title-name (doc) 274 "Returns a string to be used as name of the definition." 275 (string-downcase (title-using-kind/name (get-kind doc) (get-name doc) doc))) 276 277 (defun include-pathname (doc) 278 (let* ((kind (get-kind doc)) 279 (name (nstring-downcase 280 (if (eq 'package kind) 281 (format nil "package-~A" (alphanumize (get-name doc))) 282 (format nil "~A-~A-~A" 283 (case (get-kind doc) 284 ((function generic-function) "fun") 285 (structure "struct") 286 (variable "var") 287 (otherwise (symbol-name (get-kind doc)))) 288 (alphanumize (let ((*base-package* nil)) 289 (short-package-name (get-package doc)))) 290 (alphanumize (get-name doc))))))) 291 (make-pathname :name name :type "texinfo"))) 292 293 ;;;; documentation class and related methods 294 295 (defclass documentation () 296 ((name :initarg :name :reader get-name) 297 (kind :initarg :kind :reader get-kind) 298 (string :initarg :string :reader get-string) 299 (children :initarg :children :initform nil :reader get-children) 300 (package :initform *documentation-package* :reader get-package))) 301 302 (defmethod print-object ((documentation documentation) stream) 303 (print-unreadable-object (documentation stream :type t) 304 (princ (list (get-kind documentation) (get-name documentation)) stream))) 305 306 (defgeneric make-documentation (x doc-type string)) 307 308 (defmethod make-documentation ((x package) doc-type string) 309 (declare (ignore doc-type)) 310 (make-instance 'documentation 311 :name (name x) 312 :kind 'package 313 :string string)) 314 315 (defmethod make-documentation (x (doc-type (eql 'function)) string) 316 (declare (ignore doc-type)) 317 (let* ((fdef (and (fboundp x) (fdefinition x))) 318 (name x) 319 (kind (cond ((and (symbolp x) (special-operator-p x)) 320 'special-operator) 321 ((and (symbolp x) (macro-function x)) 322 'macro) 323 ((typep fdef 'generic-function) 324 (assert (or (symbolp name) (setf-name-p name))) 325 'generic-function) 326 (fdef 327 (assert (or (symbolp name) (setf-name-p name))) 328 'function))) 329 (children (when (eq kind 'generic-function) 330 (collect-gf-documentation fdef)))) 331 (make-instance 'documentation 332 :name (name x) 333 :string string 334 :kind kind 335 :children children))) 336 337 (defmethod make-documentation ((x method) doc-type string) 338 (declare (ignore doc-type)) 339 (make-instance 'documentation 340 :name (name x) 341 :kind 'method 342 :string string)) 343 344 (defmethod make-documentation (x (doc-type (eql 'type)) string) 345 (make-instance 'documentation 346 :name (name x) 347 :string string 348 :kind (etypecase (find-class x nil) 349 (structure-class 'structure) 350 (standard-class 'class) 351 (sb-pcl::condition-class 'condition) 352 ((or built-in-class null) 'type)))) 353 354 (defmethod make-documentation (x (doc-type (eql 'variable)) string) 355 (make-instance 'documentation 356 :name (name x) 357 :string string 358 :kind (if (constantp x) 359 'constant 360 'variable))) 361 362 (defmethod make-documentation (x (doc-type (eql 'setf)) string) 363 (declare (ignore doc-type)) 364 (make-instance 'documentation 365 :name (name x) 366 :kind 'setf-expander 367 :string string)) 368 369 (defmethod make-documentation (x doc-type string) 370 (make-instance 'documentation 371 :name (name x) 372 :kind doc-type 373 :string string)) 374 375 (defun maybe-documentation (x doc-type) 376 "Returns a DOCUMENTATION instance for X and DOC-TYPE, or NIL if 377 there is no corresponding docstring." 378 (let ((docstring (docstring x doc-type))) 379 (when docstring 380 (make-documentation x doc-type docstring)))) 381 382 (defun lambda-list (doc) 383 (case (get-kind doc) 384 ((package constant variable type structure class condition nil) 385 nil) 386 (method 387 (third (get-name doc))) 388 (t 389 ;; KLUDGE: Eugh. 390 ;; 391 ;; believe it or not, the above comment was written before CSR 392 ;; came along and obfuscated this. (2005-07-04) 393 (when (symbolp (get-name doc)) 394 (labels ((clean (x &key optional key) 395 (typecase x 396 (atom x) 397 ((cons (member &optional)) 398 (cons (car x) (clean (cdr x) :optional t))) 399 ((cons (member &key)) 400 (cons (car x) (clean (cdr x) :key t))) 401 ((cons (member &whole &environment)) 402 ;; Skip these 403 (clean (cdr x) :optional optional :key key)) 404 ((cons cons) 405 (cons 406 (cond (key (if (consp (caar x)) 407 (caaar x) 408 (caar x))) 409 (optional (caar x)) 410 (t (clean (car x)))) 411 (clean (cdr x) :key key :optional optional))) 412 (cons 413 (cons 414 (cond ((or key optional) (car x)) 415 (t (clean (car x)))) 416 (clean (cdr x) :key key :optional optional)))))) 417 (clean (sb-introspect:function-lambda-list (get-name doc)))))))) 418 419 (defun get-string-name (x) 420 (let ((name (get-name x))) 421 (cond ((symbolp name) 422 (symbol-name name)) 423 ((and (consp name) (eq 'setf (car name))) 424 (symbol-name (second name))) 425 ((stringp name) 426 name) 427 (t 428 (error "Don't know which symbol to use for name ~S" name))))) 429 430 (defun documentation< (x y) 431 (let ((p1 (position (get-kind x) *ordered-documentation-kinds*)) 432 (p2 (position (get-kind y) *ordered-documentation-kinds*))) 433 (if (or (not (and p1 p2)) (= p1 p2)) 434 (string< (get-string-name x) (get-string-name y)) 435 (< p1 p2)))) 436 437 ;;;; turning text into texinfo 438 439 (defun escape-for-texinfo (string &optional downcasep) 440 "Return STRING with characters in *TEXINFO-ESCAPED-CHARS* escaped 441 with #\@. Optionally downcase the result." 442 (let ((result (with-output-to-string (s) 443 (loop for char across string 444 when (find char *texinfo-escaped-chars*) 445 do (write-char #\@ s) 446 do (write-char char s))))) 447 (if downcasep (nstring-downcase result) result))) 448 449 (defun empty-p (line-number lines) 450 (and (< -1 line-number (length lines)) 451 (not (indentation (svref lines line-number))))) 452 453 ;;; line markups 454 455 (defvar *not-symbols* '("ANSI" "CLHS")) 456 457 (defun locate-symbols (line) 458 "Return a list of index pairs of symbol-like parts of LINE." 459 ;; This would be a good application for a regex ... 460 (let (result) 461 (flet ((grab (start end) 462 (unless (member (subseq line start end) '("ANSI" "CLHS")) 463 (push (list start end) result)))) 464 (do ((begin nil) 465 (maybe-begin t) 466 (i 0 (1+ i))) 467 ((= i (length line)) 468 ;; symbol at end of line 469 (when (and begin (or (> i (1+ begin)) 470 (not (member (char line begin) '(#\A #\I))))) 471 (grab begin i)) 472 (nreverse result)) 473 (cond 474 ((and begin (find (char line i) *symbol-delimiters*)) 475 ;; symbol end; remember it if it's not "A" or "I" 476 (when (or (> i (1+ begin)) (not (member (char line begin) '(#\A #\I)))) 477 (grab begin i)) 478 (setf begin nil 479 maybe-begin t)) 480 ((and begin (not (find (char line i) *symbol-characters*))) 481 ;; Not a symbol: abort 482 (setf begin nil)) 483 ((and maybe-begin (not begin) (find (char line i) *symbol-characters*)) 484 ;; potential symbol begin at this position 485 (setf begin i 486 maybe-begin nil)) 487 ((find (char line i) *symbol-delimiters*) 488 ;; potential symbol begin after this position 489 (setf maybe-begin t)) 490 (t 491 ;; Not reading a symbol, not at potential start of symbol 492 (setf maybe-begin nil))))))) 493 494 (defun texinfo-line (line) 495 "Format symbols in LINE texinfo-style: either as code or as 496 variables if the symbol in question is contained in symbols 497 *TEXINFO-VARIABLES*." 498 (with-output-to-string (result) 499 (let ((last 0)) 500 (dolist (symbol/index (locate-symbols line)) 501 (write-string (subseq line last (first symbol/index)) result) 502 (let ((symbol-name (apply #'subseq line symbol/index))) 503 (format result (if (member symbol-name *texinfo-variables* 504 :test #'string=) 505 "@var{~A}" 506 "@code{~A}") 507 (string-downcase symbol-name))) 508 (setf last (second symbol/index))) 509 (write-string (subseq line last) result)))) 510 511 ;;; lisp sections 512 513 (defun lisp-section-p (line line-number lines) 514 "Returns T if the given LINE looks like start of lisp code -- 515 ie. if it starts with whitespace followed by a paren or 516 semicolon, and the previous line is empty" 517 (let ((offset (indentation line))) 518 (and offset 519 (plusp offset) 520 (find (find-if-not #'whitespacep line) "(;") 521 (empty-p (1- line-number) lines)))) 522 523 (defun collect-lisp-section (lines line-number) 524 (let ((lisp (loop for index = line-number then (1+ index) 525 for line = (and (< index (length lines)) (svref lines index)) 526 while (indentation line) 527 collect line))) 528 (values (length lisp) `("@lisp" ,@lisp "@end lisp")))) 529 530 ;;; itemized sections 531 532 (defun maybe-itemize-offset (line) 533 "Return NIL or the indentation offset if LINE looks like it starts 534 an item in an itemization." 535 (let* ((offset (indentation line)) 536 (char (when offset (char line offset)))) 537 (and offset 538 (member char *itemize-start-characters* :test #'char=) 539 (char= #\Space (find-if-not (lambda (c) (char= c char)) 540 line :start offset)) 541 offset))) 542 543 (defun collect-maybe-itemized-section (lines starting-line) 544 ;; Return index of next line to be processed outside 545 (let ((this-offset (maybe-itemize-offset (svref lines starting-line))) 546 (result nil) 547 (lines-consumed 0)) 548 (loop for line-number from starting-line below (length lines) 549 for line = (svref lines line-number) 550 for indentation = (indentation line) 551 for offset = (maybe-itemize-offset line) 552 do (cond 553 ((not indentation) 554 ;; empty line -- inserts paragraph. 555 (push "" result) 556 (incf lines-consumed)) 557 ((and offset (> indentation this-offset)) 558 ;; nested itemization -- handle recursively 559 ;; FIXME: tables in itemizations go wrong 560 (multiple-value-bind (sub-lines-consumed sub-itemization) 561 (collect-maybe-itemized-section lines line-number) 562 (when sub-lines-consumed 563 (incf line-number (1- sub-lines-consumed)) ; +1 on next loop 564 (incf lines-consumed sub-lines-consumed) 565 (setf result (nconc (nreverse sub-itemization) result))))) 566 ((and offset (= indentation this-offset)) 567 ;; start of new item 568 (push (format nil "@item ~A" 569 (texinfo-line (subseq line (1+ offset)))) 570 result) 571 (incf lines-consumed)) 572 ((and (not offset) (> indentation this-offset)) 573 ;; continued item from previous line 574 (push (texinfo-line line) result) 575 (incf lines-consumed)) 576 (t 577 ;; end of itemization 578 (loop-finish)))) 579 ;; a single-line itemization isn't. 580 (if (> (count-if (lambda (line) (> (length line) 0)) result) 1) 581 (values lines-consumed `("@itemize" ,@(reverse result) "@end itemize")) 582 nil))) 583 584 ;;; table sections 585 586 (defun tabulation-body-p (offset line-number lines) 587 (when (< line-number (length lines)) 588 (let ((offset2 (indentation (svref lines line-number)))) 589 (and offset2 (< offset offset2))))) 590 591 (defun tabulation-p (offset line-number lines direction) 592 (let ((step (ecase direction 593 (:backwards (1- line-number)) 594 (:forwards (1+ line-number))))) 595 (when (and (plusp line-number) (< line-number (length lines))) 596 (and (eql offset (indentation (svref lines line-number))) 597 (or (when (eq direction :backwards) 598 (empty-p step lines)) 599 (tabulation-p offset step lines direction) 600 (tabulation-body-p offset step lines)))))) 601 602 (defun maybe-table-offset (line-number lines) 603 "Return NIL or the indentation offset if LINE looks like it starts 604 an item in a tabulation. Ie, if it is (1) indented, (2) preceded by an 605 empty line, another tabulation label, or a tabulation body, (3) and 606 followed another tabulation label or a tabulation body." 607 (let* ((line (svref lines line-number)) 608 (offset (indentation line)) 609 (prev (1- line-number)) 610 (next (1+ line-number))) 611 (when (and offset (plusp offset)) 612 (and (or (empty-p prev lines) 613 (tabulation-body-p offset prev lines) 614 (tabulation-p offset prev lines :backwards)) 615 (or (tabulation-body-p offset next lines) 616 (tabulation-p offset next lines :forwards)) 617 offset)))) 618 619 ;;; FIXME: This and itemization are very similar: could they share 620 ;;; some code, mayhap? 621 622 (defun collect-maybe-table-section (lines starting-line) 623 ;; Return index of next line to be processed outside 624 (let ((this-offset (maybe-table-offset starting-line lines)) 625 (result nil) 626 (lines-consumed 0)) 627 (loop for line-number from starting-line below (length lines) 628 for line = (svref lines line-number) 629 for indentation = (indentation line) 630 for offset = (maybe-table-offset line-number lines) 631 do (cond 632 ((not indentation) 633 ;; empty line -- inserts paragraph. 634 (push "" result) 635 (incf lines-consumed)) 636 ((and offset (= indentation this-offset)) 637 ;; start of new item, or continuation of previous item 638 (if (and result (search "@item" (car result) :test #'char=)) 639 (push (format nil "@itemx ~A" (texinfo-line line)) 640 result) 641 (progn 642 (push "" result) 643 (push (format nil "@item ~A" (texinfo-line line)) 644 result))) 645 (incf lines-consumed)) 646 ((> indentation this-offset) 647 ;; continued item from previous line 648 (push (texinfo-line line) result) 649 (incf lines-consumed)) 650 (t 651 ;; end of itemization 652 (loop-finish)))) 653 ;; a single-line table isn't. 654 (if (> (count-if (lambda (line) (> (length line) 0)) result) 1) 655 (values lines-consumed 656 `("" "@table @emph" ,@(reverse result) "@end table" "")) 657 nil))) 658 659 ;;; section markup 660 661 (defmacro with-maybe-section (index &rest forms) 662 `(multiple-value-bind (count collected) (progn ,@forms) 663 (when count 664 (dolist (line collected) 665 (write-line line *texinfo-output*)) 666 (incf ,index (1- count))))) 667 668 (defun write-texinfo-string (string &optional lambda-list) 669 "Try to guess as much formatting for a raw docstring as possible." 670 (let ((*texinfo-variables* (flatten lambda-list)) 671 (lines (string-lines (escape-for-texinfo string nil)))) 672 (loop for line-number from 0 below (length lines) 673 for line = (svref lines line-number) 674 do (cond 675 ((with-maybe-section line-number 676 (and (lisp-section-p line line-number lines) 677 (collect-lisp-section lines line-number)))) 678 ((with-maybe-section line-number 679 (and (maybe-itemize-offset line) 680 (collect-maybe-itemized-section lines line-number)))) 681 ((with-maybe-section line-number 682 (and (maybe-table-offset line-number lines) 683 (collect-maybe-table-section lines line-number)))) 684 (t 685 (write-line (texinfo-line line) *texinfo-output*)))))) 686 687 ;;;; texinfo formatting tools 688 689 (defun hide-superclass-p (class-name super-name) 690 (let ((super-package (symbol-package super-name))) 691 (or 692 ;; KLUDGE: We assume that we don't want to advertise internal 693 ;; classes in CP-lists, unless the symbol we're documenting is 694 ;; internal as well. 695 (and (member super-package #.'(mapcar #'find-package *undocumented-packages*)) 696 (not (eq super-package (symbol-package class-name)))) 697 ;; KLUDGE: We don't generally want to advertise SIMPLE-ERROR or 698 ;; SIMPLE-CONDITION in the CPLs of conditions that inherit them 699 ;; simply as a matter of convenience. The assumption here is that 700 ;; the inheritance is incidental unless the name of the condition 701 ;; begins with SIMPLE-. 702 (and (member super-name '(simple-error simple-condition)) 703 (let ((prefix "SIMPLE-")) 704 (mismatch prefix (string class-name) :end2 (length prefix))) 705 t ; don't return number from MISMATCH 706 )))) 707 708 (defun hide-slot-p (symbol slot) 709 ;; FIXME: There is no pricipal reason to avoid the slot docs fo 710 ;; structures and conditions, but their DOCUMENTATION T doesn't 711 ;; currently work with them the way we'd like. 712 (not (and (typep (find-class symbol nil) 'standard-class) 713 (docstring slot t)))) 714 715 (defun texinfo-anchor (doc) 716 (format *texinfo-output* "@anchor{~A}~%" (node-name doc))) 717 718 ;;; KLUDGE: &AUX *PRINT-PRETTY* here means "no linebreaks please" 719 (defun texinfo-begin (doc &aux *print-pretty*) 720 (let ((kind (get-kind doc))) 721 (format *texinfo-output* "@~A {~:(~A~)} ~({~A}~@[ ~{~A~^ ~}~]~)~%" 722 (case kind 723 ((package constant variable) 724 "defvr") 725 ((structure class condition type) 726 "deftp") 727 (t 728 "deffn")) 729 (map 'string (lambda (char) (if (eql char #\-) #\Space char)) (string kind)) 730 (title-name doc) 731 ;; &foo would be amusingly bold in the pdf thanks to TeX/Texinfo 732 ;; interactions,so we escape the ampersand -- amusingly for TeX. 733 ;; sbcl.texinfo defines macros that expand @&key and friends to &key. 734 (mapcar (lambda (name) 735 (if (member name lambda-list-keywords) 736 (format nil "@~A" name) 737 name)) 738 (lambda-list doc))))) 739 740 (defun texinfo-index (doc) 741 (let ((title (title-name doc))) 742 (case (get-kind doc) 743 ((structure type class condition) 744 (format *texinfo-output* "@tindex ~A~%" title)) 745 ((variable constant) 746 (format *texinfo-output* "@vindex ~A~%" title)) 747 ((compiler-macro function method-combination macro generic-function) 748 (format *texinfo-output* "@findex ~A~%" title))))) 749 750 (defun texinfo-inferred-body (doc) 751 (when (member (get-kind doc) '(class structure condition)) 752 (let ((name (get-name doc))) 753 ;; class precedence list 754 (format *texinfo-output* "Class precedence list: @code{~(~{@lw{~A}~^, ~}~)}~%~%" 755 (remove-if (lambda (class) (hide-superclass-p name class)) 756 (mapcar #'class-name (ensure-class-precedence-list (find-class name))))) 757 ;; slots 758 (let ((slots (remove-if (lambda (slot) (hide-slot-p name slot)) 759 (class-direct-slots (find-class name))))) 760 (when slots 761 (format *texinfo-output* "Slots:~%@itemize~%") 762 (dolist (slot slots) 763 (format *texinfo-output* 764 "@item ~(@code{~A}~#[~:; --- ~]~ 765 ~:{~2*~@[~2:*~A~P: ~{@code{@w{~S}}~^, ~}~]~:^; ~}~)~%~%" 766 (slot-definition-name slot) 767 (remove 768 nil 769 (mapcar 770 (lambda (name things) 771 (if things 772 (list name (length things) things))) 773 '("initarg" "reader" "writer") 774 (list 775 (slot-definition-initargs slot) 776 (slot-definition-readers slot) 777 (slot-definition-writers slot))))) 778 ;; FIXME: Would be neater to handler as children 779 (write-texinfo-string (docstring slot t))) 780 (format *texinfo-output* "@end itemize~%~%")))))) 781 782 (defun texinfo-body (doc) 783 (write-texinfo-string (get-string doc))) 784 785 (defun texinfo-end (doc) 786 (write-line (case (get-kind doc) 787 ((package variable constant) "@end defvr") 788 ((structure type class condition) "@end deftp") 789 (t "@end deffn")) 790 *texinfo-output*)) 791 792 (defun write-texinfo (doc) 793 "Writes TexInfo for a DOCUMENTATION instance to *TEXINFO-OUTPUT*." 794 (texinfo-anchor doc) 795 (texinfo-begin doc) 796 (texinfo-index doc) 797 (texinfo-inferred-body doc) 798 (texinfo-body doc) 799 (texinfo-end doc) 800 ;; FIXME: Children should be sorted one way or another 801 (mapc #'write-texinfo (get-children doc))) 802 803 ;;;; main logic 804 805 (defun collect-gf-documentation (gf) 806 "Collects method documentation for the generic function GF" 807 (loop for method in (generic-function-methods gf) 808 for doc = (maybe-documentation method t) 809 when doc 810 collect doc)) 811 812 (defun collect-name-documentation (name) 813 (loop for type in *documentation-types* 814 for doc = (maybe-documentation name type) 815 when doc 816 collect doc)) 817 818 (defun collect-symbol-documentation (symbol) 819 "Collects all docs for a SYMBOL and (SETF SYMBOL), returns a list of 820 the form DOC instances. See `*documentation-types*' for the possible 821 values of doc-type." 822 (nconc (collect-name-documentation symbol) 823 (collect-name-documentation (list 'setf symbol)))) 824 825 (defun collect-documentation (package &optional ht) 826 "Collects all documentation for all external symbols of the given 827 package, as well as for the package itself." 828 (let* ((*documentation-package* (find-package package)) 829 (docs nil)) 830 (check-type package package) 831 (do-external-symbols (symbol package) 832 (unless (and ht 833 (nth-value 1 (alexandria:ensure-gethash symbol ht t))) 834 (setf (gethash symbol ht) t) 835 (setf docs (nconc (collect-symbol-documentation symbol) docs)))) 836 (let ((doc (maybe-documentation *documentation-package* t))) 837 (when doc 838 (push doc docs))) 839 docs)) 840 841 (defmacro with-texinfo-file (pathname &body forms) 842 `(with-open-file (*texinfo-output* ,pathname 843 :direction :output 844 :if-does-not-exist :create 845 :if-exists :supersede) 846 ,@forms)) 847 848 (defun write-ifnottex () 849 ;; We use @&key, etc to escape & from TeX in lambda lists -- so we need to 850 ;; define them for info as well. 851 ;; Texinfo > 5 doesn't allow "&" in macro names any more; 852 ;; see also https://bugs.launchpad.net/asdf/+bug/1172567 or 853 ;; ASDF commit dfa4643b212b194f2d673b6f0d9c7d4b19d823ba 854 (flet ((macro (name) 855 (let ((string (string-downcase name))) 856 (format *texinfo-output* "@macro ~A~%&~A~%@end macro~%" string string)))) 857 (macro 'allow-other-keys) 858 (macro 'optional) 859 (macro 'rest) 860 (macro 'key) 861 (macro 'body))) 862 863 (defun generate-includes (directory packages &key (base-package :cl-user)) 864 "Create files in `directory' containing Texinfo markup of all 865 docstrings of each exported symbol in `packages'. `directory' is 866 created if necessary. If you supply a namestring that doesn't end in a 867 slash, you lose. The generated files are of the form 868 \"<doc-type>_<packagename>_<symbol-name>.texinfo\" and can be included 869 via @include statements. Texinfo syntax-significant characters are 870 escaped in symbol names, but if a docstring contains invalid Texinfo 871 markup, you lose." 872 (handler-bind ((warning #'muffle-warning)) 873 (let* ((directory (merge-pathnames (pathname directory))) 874 (*base-package* (find-package base-package)) 875 (syms-seen (make-hash-table :test #'eq))) 876 (ensure-directories-exist directory) 877 (dolist (package packages) 878 (dolist (doc (collect-documentation (find-package package) syms-seen)) 879 (with-texinfo-file (merge-pathnames (include-pathname doc) directory) 880 (write-texinfo doc)))) 881 (with-texinfo-file (merge-pathnames "ifnottex.texinfo" directory) 882 (write-ifnottex)) 883 directory))) 884 885 (defun document-package (package &optional filename) 886 "Create a file containing all available documentation for the 887 exported symbols of `package' in Texinfo format. If `filename' is not 888 supplied, a file \"<packagename>.texinfo\" is generated. 889 890 The definitions can be referenced using Texinfo statements like 891 @ref{<doc-type>_<packagename>_<symbol-name>.texinfo}. Texinfo 892 syntax-significant characters are escaped in symbol names, but if a 893 docstring contains invalid Texinfo markup, you lose." 894 (handler-bind ((warning #'muffle-warning)) 895 (let* ((package (find-package package)) 896 (filename (or filename (make-pathname 897 :name (string-downcase (short-package-name package)) 898 :type "texinfo"))) 899 (docs (sort (collect-documentation package) #'documentation<))) 900 (with-texinfo-file filename 901 (dolist (doc docs) 902 (write-texinfo doc))) 903 filename)))