tdocstrings.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP HTML git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/ DIR Log DIR Files DIR Refs DIR Tags DIR LICENSE --- tdocstrings.lisp (34765B) --- 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)))