parse-docstrings.lisp

   1 ;;; -*- lisp; show-trailing-whitespace: t; indent-tabs: nil -*-
   2
   3 ;;;; Part of this software was originally written as docstrings.lisp in
   4 ;;;; SBCL, but is now part of the parse-docstrings project.  The file
   5 ;;;; docstrings.lisp was written by Rudi Schlatte <rudi@constantly.at>,
   6 ;;;; mangled by Nikodemus Siivola, turned into a stand-alone project by
   7 ;;;; Luis Oliveira.  SBCL is in the public domain and is provided with
   8 ;;;; absolutely no warranty.
   9
  10 ;;;; parse-docstrings is:
  11 ;;;;
  12 ;;;; Copyright (c) 2008 David Lichteblau:
  13 ;;;;
  14 ;;;; Permission is hereby granted, free of charge, to any person
  15 ;;;; obtaining a copy of this software and associated documentation
  16 ;;;; files (the "Software"), to deal in the Software without
  17 ;;;; restriction, including without limitation the rights to use, copy,
  18 ;;;; modify, merge, publish, distribute, sublicense, and/or sell copies
  19 ;;;; of the Software, and to permit persons to whom the Software is
  20 ;;;; furnished to do so, subject to the following conditions:
  21 ;;;;
  22 ;;;; The above copyright notice and this permission notice shall be
  23 ;;;; included in all copies or substantial portions of the Software.
  24 ;;;;
  25 ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  26 ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  27 ;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  28 ;;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  29 ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  30 ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  31 ;;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  32 ;;;; DEALINGS IN THE SOFTWARE.
  33
  34 #+sbcl ;; FIXME: should handle this in the .asd file
  35 (eval-when (:compile-toplevel :load-toplevel :execute)
  36   (require 'sb-introspect))
  37
  38 (in-package #:parse-docstrings)
  39
  40 (defun function-arglist (function)
  41   #+sbcl (sb-introspect:function-arglist function)
  42   #-sbcl (error "function-arglist unimplemented"))
  43
  44 ;;;; various specials and parameters
  45
  46 (defvar *documentation-package*)
  47 (defvar *documentation-package-name*)
  48
  49 (defparameter *documentation-types*
  50   '(function
  51     method-combination
  52     setf
  53     ;;structure  ; also handled by `type'
  54     type
  55     variable)
  56   "A list of symbols accepted as second argument of `documentation'")
  57
  58 (defparameter *ordered-documentation-kinds*
  59   '(package type structure condition class macro))
  60
  61 ;;;; utilities
  62
  63 (defun flatten (list)
  64   (cond ((null list)
  65          nil)
  66         ((consp (car list))
  67          (nconc (flatten (car list)) (flatten (cdr list))))
  68         ((null (cdr list))
  69          (cons (car list) nil))
  70         (t
  71          (cons (car list) (flatten (cdr list))))))
  72
  73 (defun flatten-to-string (list)
  74   (format nil "~{~A~^~%~}" (flatten list)))
  75
  76 (defun setf-name-p (name)
  77   (or (symbolp name)
  78       (and (listp name) (= 2 (length name)) (eq (car name) 'setf))))
  79
  80 (defgeneric specializer-name (specializer))
  81
  82 (defmethod specializer-name ((specializer eql-specializer))
  83   (list 'eql (eql-specializer-object specializer)))
  84
  85 (defmethod specializer-name ((specializer class))
  86   (class-name specializer))
  87
  88 (defun specialized-lambda-list (method)
  89   ;; courtecy of AMOP p. 61
  90   (let* ((specializers (method-specializers method))
  91          (lambda-list (method-lambda-list method))
  92          (n-required (length specializers)))
  93     (append (mapcar (lambda (arg specializer)
  94                       (if  (eq specializer (find-class 't))
  95                            arg
  96                            `(,arg ,(specializer-name specializer))))
  97                     (subseq lambda-list 0 n-required)
  98                     specializers)
  99            (subseq lambda-list n-required))))
 100
 101 (defun docstring (x doc-type)
 102   (handler-bind ((warning #'muffle-warning))
 103     (cl:documentation x doc-type)))
 104
 105
 106
 107 ;;;; generating various names
 108
 109 (defgeneric name (thing)
 110   (:documentation "Name for a documented thing. Names are either
 111 symbols or lists of symbols."))
 112
 113 (defmethod name ((symbol symbol))
 114   symbol)
 115
 116 (defmethod name ((cons cons))
 117   cons)
 118
 119 (defmethod name ((package package))
 120   (package-name package))
 121
 122 (defmethod name ((method method))
 123   (list
 124    (generic-function-name (method-generic-function method))
 125    (method-qualifiers method)
 126    (specialized-lambda-list method)))
 127
 128
 129 ;;;; finding a package
 130
 131 (defmethod thing-to-package ((symbol symbol))
 132   (symbol-package symbol))
 133
 134 (defmethod thing-to-package ((setf-name cons))
 135   (symbol-package (second setf-name)))
 136
 137 (defmethod thing-to-package ((package package))
 138   package)
 139
 140 (defmethod thing-to-package ((function function))
 141   (thing-to-package
 142    ;; fixme: use swank?
 143    #+sbcl (sb-impl::%fun-name function)))
 144
 145 (defmethod thing-to-package ((function generic-function))
 146   (thing-to-package (generic-function-name function)))
 147
 148 (defmethod thing-to-package ((method method))
 149   (thing-to-package (generic-function-name (method-generic-function method))))
 150
 151
 152
 153 ;;;; frontend selection
 154
 155 (defvar *default-docstring-parser*
 156   'parse-docstrings.sbcl:parse-docstring)
 157
 158 (defgeneric docstring-parser-for (x))
 159
 160 (defmethod docstring-parser-for ((x package))
 161   (let ((configuration
 162          (find-symbol "DOCSTRING-PARSER" x)))
 163     (if (and configuration (fboundp configuration))
 164         (let ((parser (funcall configuration)))
 165           (unless (and parser
 166                        (typep parser '(and (not null) (or symbol cons)))
 167                        ;; fixme: fboundp errors
 168                        (fboundp parser))
 169             (error "expected a parser function from ~A but got ~A"
 170                    configuration parser))
 171           parser)
 172         *default-docstring-parser*)))
 173
 174 (defmethod docstring-parser-for ((x symbol))
 175   (docstring-parser-for (symbol-package x)))
 176
 177
 178 ;;;; methods related to the documentation* class
 179
 180 (defun get-symbol (doc)
 181   (let ((name (get-name doc)))
 182     (cond ((symbolp name)
 183            name)
 184           ((and (consp name) (eq 'setf (car name)))
 185            (second name))
 186           (t
 187            (error "Don't know which symbol to sort by: ~S" name)))))
 188
 189 (defmethod print-object ((documentation documentation*) stream)
 190   (print-unreadable-object (documentation stream :type t)
 191     (princ (list (get-kind documentation) (get-name documentation)) stream)))
 192
 193 (defgeneric make-documentation (x doc-type string))
 194
 195 (defmethod make-documentation :around (x doc-type string)
 196   (let ((doc (call-next-method)))
 197     (multiple-value-bind (markup annotations)
 198         (let ((*package* *documentation-package*))
 199           (funcall (docstring-parser-for x) string))
 200       (setf (child-elements doc)
 201             (append (child-elements doc) (simplify-markup markup)))
 202       (setf (documentation-annotations doc)
 203             (merge-annotations (documentation-annotations doc)
 204                                annotations)))
 205     doc))
 206
 207 (defmethod make-documentation ((x package) doc-type string)
 208   (declare (ignore doc-type string))
 209   (make-instance 'documentation*
 210                  :name (name x)
 211                  :kind 'package))
 212
 213 (defmethod make-documentation (x (doc-type (eql 'function)) string)
 214   (declare (ignore doc-type string))
 215   (let* ((fdef (and (fboundp x) (fdefinition x)))
 216          (name x)
 217          (kind (cond ((and (symbolp x) (special-operator-p x))
 218                       'special-operator)
 219                      ((and (symbolp x) (macro-function x))
 220                       'macro)
 221                      ((typep fdef 'generic-function)
 222                       (assert (or (symbolp name) (setf-name-p name)))
 223                       'generic-function)
 224                      (fdef
 225                       (assert (or (symbolp name) (setf-name-p name)))
 226                       'function)))
 227          (methods (when (eq kind 'generic-function)
 228                     (collect-gf-documentation fdef))))
 229     (make-instance 'documentation*
 230                    :name (name x)
 231                    :kind kind
 232                    :methods methods)))
 233
 234 (defmethod make-documentation ((x method) doc-type string)
 235   (declare (ignore doc-type string))
 236   (make-instance 'documentation*
 237                  :name (name x)
 238                  :kind 'method))
 239
 240 (defmethod make-documentation (x (doc-type (eql 'type)) string)
 241   (declare (ignore string))
 242   (make-instance 'documentation*
 243                  :name (name x)
 244                  :kind (etypecase (find-class x nil)
 245                          (structure-class 'structure)
 246                          (standard-class 'class)
 247                          (sb-pcl::condition-class 'condition)
 248                          ((or built-in-class null) 'type))))
 249
 250 (defmethod make-documentation (x (doc-type (eql 'variable)) string)
 251   (declare (ignore string))
 252   (make-instance 'documentation*
 253                  :name (name x)
 254                  :kind (if (constantp x)
 255                            'constant
 256                            'variable)))
 257
 258 (defmethod make-documentation (x (doc-type (eql 'setf)) string)
 259   (declare (ignore doc-type string))
 260   (make-instance 'documentation*
 261                  :name (name x)
 262                  :kind 'setf-expander))
 263
 264 (defmethod make-documentation (x doc-type string)
 265   (declare (ignore string))
 266   (make-instance 'documentation*
 267                  :name (name x)
 268                  :kind doc-type))
 269
 270 (defun documentation* (x doc-type)
 271   "Returns a DOCUMENTATION instance for X and DOC-TYPE, or NIL if
 272 there is no corresponding docstring."
 273   (let* ((*documentation-package* (thing-to-package x))
 274          (*documentation-package-name* (package-name *documentation-package*))
 275          (docstring (docstring x doc-type)))
 276     (when (plusp (length docstring))
 277       (make-documentation x doc-type docstring))))
 278
 279 (defun lambda-list (doc)
 280   ;; KLUDGE: Eugh.
 281   ;;
 282   ;; believe it or not, the above comment was written before CSR came along
 283   ;; and obfuscated this. (2005-07-04)
 284   (labels ((clean (x &key optional key)
 285              (typecase x
 286                (atom x)
 287                ((cons (member &optional))
 288                 (cons (car x) (clean (cdr x) :optional t)))
 289                ((cons (member &key))
 290                 (cons (car x) (clean (cdr x) :key t)))
 291                ;; &ENVIRONMENT ENV and &WHOLE FORM is not interesting to the user.
 292                ((cons (member &environment &whole))
 293                 (clean (cddr x) :optional optional :key key))
 294                ((cons cons)
 295                 (cons
 296                  (cond (key (if (consp (caar x))
 297                                 (caaar x)
 298                                 (caar x)))
 299                        (optional (caar x))
 300                        (t (clean (car x))))
 301                  (clean (cdr x) :key key :optional optional)))
 302                (cons
 303                 (cons
 304                  (cond ((or key optional) (car x))
 305                        (t (clean (car x))))
 306                  (clean (cdr x) :key key :optional optional))))))
 307     (case (get-kind doc)
 308       ((package constant variable structure class condition nil)
 309        nil)
 310 ;;;       ((type)
 311 ;;;        ;; FIND-SYMBOL to avoid compilation errors on older SBCL versions:
 312 ;;;        (clean (funcall (find-symbol "INFO" :sb-int)
 313 ;;;                    :type
 314 ;;;                    :lambda-list
 315 ;;;                    (get-name doc))))
 316       (method
 317        (third (get-name doc)))
 318       (t
 319        (when (symbolp (get-name doc))
 320          (clean (function-arglist (get-name doc))))))))
 321
 322 (defun documentation< (x y)
 323   (let ((p1 (position (get-kind x) *ordered-documentation-kinds*))
 324         (p2 (position (get-kind y) *ordered-documentation-kinds*)))
 325     (cond ((and p1 p2 (/= p1 p2))
 326            (< p1 p2))
 327           ((and (or p1 p2) (not (and p1 p2)))
 328            (and p1 t))
 329           (t
 330            (string< (string (get-symbol x)) (string (get-symbol y)))))))
 331
 332
 333 ;;;; markup tree beautification
 334
 335 (defun simplify-markup (nodes)
 336   (cond
 337     ((endp nodes)
 338      nil)
 339     ((typep (car nodes) 'text)
 340      (let ((str
 341             (with-output-to-string (s)
 342               (iter (while (typep (car nodes) 'text))
 343                     (write-string (characters (car nodes)) s)
 344                     (pop nodes)))))
 345        (if (plusp (length str))
 346            (cons (make-text str) (simplify-markup nodes))
 347            (simplify-markup nodes))))
 348     (t
 349      (let ((car (car nodes)))
 350        (setf (child-elements car)
 351              (simplify-markup (child-elements car)))
 352        (cons car (simplify-markup (rest nodes)))))))
 353
 354
 355 ;;;; MISSING-SYMBOL support functions
 356
 357 (defun parse-symbol (str package)
 358   (handler-case
 359       (let ((*package* package))
 360         (read-from-string str))
 361     (error ()
 362       (parse-missing-symbol str package))))
 363
 364 ;;; KLUDGE, can we do better?
 365 (defun parse-missing-symbol (str package)
 366   (let ((pos1 (position #\: str)))
 367     (if pos1
 368         (let ((pos2 (position #\: str :from-end t)))
 369           (make-missing-symbol (subseq str 0 pos1)
 370                                (subseq str (1+ pos2))))
 371         (make-missing-symbol str package))))
 372
 373 ;;; works for both missing and actual symbols
 374 (defun look-up-missing-symbol (symbol doc-type)
 375   (hyperdoc:lookup (missing-symbol-package-name symbol)
 376                    (missing-symbol-name symbol)
 377                    doc-type))
 378
 379
 380 ;;;; main logic
 381
 382 (defun collect-gf-documentation (gf)
 383   "Collects method documentation for the generic function GF"
 384   (iter (for method in (generic-function-methods gf))
 385         (for doc = (documentation* method t))
 386         (when doc
 387           (collect doc))))
 388
 389 (defun collect-name-documentation (name)
 390   (iter (for type in *documentation-types*)
 391         (for doc = (documentation* name type))
 392         (when doc
 393           (collect doc))))
 394
 395 (defun collect-symbol-documentation (symbol)
 396   "Collects all docs for a SYMBOL and (SETF SYMBOL), returns a list of
 397 the form DOC instances. See `*documentation-types*' for the possible
 398 values of doc-type."
 399   (nconc (collect-name-documentation symbol)
 400          (collect-name-documentation (list 'setf symbol))))
 401
 402 (defun collect-documentation (package &optional package-name)
 403   "Collects all documentation for all external symbols of the given
 404 package, as well as for the package itself."
 405   (let* ((*documentation-package* (find-package package))
 406          (*documentation-package-name*
 407           (or package-name (package-name *documentation-package*)))
 408          (docs nil))
 409     (check-type package package)
 410     (do-external-symbols (symbol package)
 411       (setf docs (nconc (collect-symbol-documentation symbol) docs)))
 412     (let ((doc (documentation* *documentation-package* t)))
 413       (when doc
 414         (push doc docs)))
 415     docs))