parse-docstrings.lisp

   1 ;;; -*- lisp -*-
   2
   3 ;;;; This software was originally part of the SBCL software system.
   4 ;;;; SBCL is in the public domain and is provided with absolutely no warranty.
   5 ;;;; See the COPYING file for more information.
   6 ;;;;
   7 ;;;; Written by Rudi Schlatte <rudi@constantly.at>, mangled
   8 ;;;; by Nikodemus Siivola, Luis Oliveira, David Lichteblau, and others.
   9
  10 ;;;; TODO
  11 ;;;; * This is getting complicated enough that tests would be good
  12
  13 #+sbcl ;; FIXME: should handle this in the .asd file
  14 (eval-when (:compile-toplevel :load-toplevel :execute)
  15   (require 'sb-introspect))
  16
  17 (in-package #:parse-docstrings)
  18
  19 (defun function-arglist (function)
  20   #+sbcl (sb-introspect:function-arglist function)
  21   #-sbcl (error "function-arglist unimplemented"))
  22
  23 ;;;; various specials and parameters
  24
  25 (defvar *documentation-package*)
  26 (defvar *documentation-package-name*)
  27
  28 (defparameter *documentation-types*
  29   '(function
  30     method-combination
  31     setf
  32     ;;structure  ; also handled by `type'
  33     type
  34     variable)
  35   "A list of symbols accepted as second argument of `documentation'")
  36
  37 (defparameter *ordered-documentation-kinds*
  38   '(package type structure condition class macro))
  39
  40 ;;;; utilities
  41
  42 (defun flatten (list)
  43   (cond ((null list)
  44          nil)
  45         ((consp (car list))
  46          (nconc (flatten (car list)) (flatten (cdr list))))
  47         ((null (cdr list))
  48          (cons (car list) nil))
  49         (t
  50          (cons (car list) (flatten (cdr list))))))
  51
  52 (defun flatten-to-string (list)
  53   (format nil "~{~A~^~%~}" (flatten list)))
  54
  55 (defun setf-name-p (name)
  56   (or (symbolp name)
  57       (and (listp name) (= 2 (length name)) (eq (car name) 'setf))))
  58
  59 (defgeneric specializer-name (specializer))
  60
  61 (defmethod specializer-name ((specializer eql-specializer))
  62   (list 'eql (eql-specializer-object specializer)))
  63
  64 (defmethod specializer-name ((specializer class))
  65   (class-name specializer))
  66
  67 (defun specialized-lambda-list (method)
  68   ;; courtecy of AMOP p. 61
  69   (let* ((specializers (method-specializers method))
  70          (lambda-list (method-lambda-list method))
  71          (n-required (length specializers)))
  72     (append (mapcar (lambda (arg specializer)
  73                       (if  (eq specializer (find-class 't))
  74                            arg
  75                            `(,arg ,(specializer-name specializer))))
  76                     (subseq lambda-list 0 n-required)
  77                     specializers)
  78            (subseq lambda-list n-required))))
  79
  80 (defun docstring (x doc-type)
  81   (handler-bind ((warning #'muffle-warning))
  82     (cl:documentation x doc-type)))
  83
  84
  85
  86 ;;;; generating various names
  87
  88 (defgeneric name (thing)
  89   (:documentation "Name for a documented thing. Names are either
  90 symbols or lists of symbols."))
  91
  92 (defmethod name ((symbol symbol))
  93   symbol)
  94
  95 (defmethod name ((cons cons))
  96   cons)
  97
  98 (defmethod name ((package package))
  99   (package-name package))
 100
 101 (defmethod name ((method method))
 102   (list
 103    (generic-function-name (method-generic-function method))
 104    (method-qualifiers method)
 105    (specialized-lambda-list method)))
 106
 107
 108 ;;;; frontend selection
 109
 110 (defvar *default-docstring-parser*
 111   'parse-docstrings.sbcl:parse-docstring)
 112
 113 (defgeneric docstring-parser-for (x))
 114
 115 (defmethod docstring-parser-for ((x package))
 116   (let ((configuration
 117          (find-symbol "DOCSTRING-PARSER" x)))
 118     (or (and configuration
 119              (funcall configuration))
 120         *default-docstring-parser*)))
 121
 122 (defmethod docstring-parser-for ((x symbol))
 123   (docstring-parser-for (symbol-package x)))
 124
 125
 126 ;;;; methods related to the documentation* class
 127
 128 (defun get-symbol (doc)
 129   (let ((name (get-name doc)))
 130     (cond ((symbolp name)
 131            name)
 132           ((and (consp name) (eq 'setf (car name)))
 133            (second name))
 134           (t
 135            (error "Don't know which symbol to sort by: ~S" name)))))
 136
 137 (defmethod print-object ((documentation documentation*) stream)
 138   (print-unreadable-object (documentation stream :type t)
 139     (princ (list (get-kind documentation) (get-name documentation)) stream)))
 140
 141 (defgeneric make-documentation (x doc-type string))
 142
 143 (defmethod make-documentation :around (x doc-type string)
 144   (let ((doc (call-next-method)))
 145     (setf (get-content doc)
 146           (funcall (docstring-parser-for (if (packagep x) x (name x))) string))
 147     doc))
 148
 149 (defmethod make-documentation ((x package) doc-type string)
 150   (declare (ignore doc-type string))
 151   (make-instance 'documentation*
 152                  :name (name x)
 153                  :kind 'package))
 154
 155 (defmethod make-documentation (x (doc-type (eql 'function)) string)
 156   (declare (ignore doc-type string))
 157   (let* ((fdef (and (fboundp x) (fdefinition x)))
 158          (name x)
 159          (kind (cond ((and (symbolp x) (special-operator-p x))
 160                       'special-operator)
 161                      ((and (symbolp x) (macro-function x))
 162                       'macro)
 163                      ((typep fdef 'generic-function)
 164                       (assert (or (symbolp name) (setf-name-p name)))
 165                       'generic-function)
 166                      (fdef
 167                       (assert (or (symbolp name) (setf-name-p name)))
 168                       'function)))
 169          (children (when (eq kind 'generic-function)
 170                      (collect-gf-documentation fdef))))
 171     (make-instance 'documentation*
 172                    :name (name x)
 173                    :kind kind
 174                    :children children)))
 175
 176 (defmethod make-documentation ((x method) doc-type string)
 177   (declare (ignore doc-type string))
 178   (make-instance 'documentation*
 179                  :name (name x)
 180                  :kind 'method))
 181
 182 (defmethod make-documentation (x (doc-type (eql 'type)) string)
 183   (declare (ignore string))
 184   (make-instance 'documentation*
 185                  :name (name x)
 186                  :kind (etypecase (find-class x nil)
 187                          (structure-class 'structure)
 188                          (standard-class 'class)
 189                          (sb-pcl::condition-class 'condition)
 190                          ((or built-in-class null) 'type))))
 191
 192 (defmethod make-documentation (x (doc-type (eql 'variable)) string)
 193   (declare (ignore string))
 194   (make-instance 'documentation*
 195                  :name (name x)
 196                  :kind (if (constantp x)
 197                            'constant
 198                            'variable)))
 199
 200 (defmethod make-documentation (x (doc-type (eql 'setf)) string)
 201   (declare (ignore doc-type string))
 202   (make-instance 'documentation*
 203                  :name (name x)
 204                  :kind 'setf-expander))
 205
 206 (defmethod make-documentation (x doc-type string)
 207   (declare (ignore string))
 208   (make-instance 'documentation*
 209                  :name (name x)
 210                  :kind doc-type))
 211
 212 (defun documentation* (x doc-type)
 213   "Returns a DOCUMENTATION instance for X and DOC-TYPE, or NIL if
 214 there is no corresponding docstring."
 215   (let ((docstring (docstring x doc-type)))
 216     (when (plusp (length docstring))
 217       (make-documentation x doc-type docstring))))
 218
 219 (defun lambda-list (doc)
 220   ;; KLUDGE: Eugh.
 221   ;;
 222   ;; believe it or not, the above comment was written before CSR came along
 223   ;; and obfuscated this. (2005-07-04)
 224   (labels ((clean (x &key optional key)
 225              (typecase x
 226                (atom x)
 227                ((cons (member &optional))
 228                 (cons (car x) (clean (cdr x) :optional t)))
 229                ((cons (member &key))
 230                 (cons (car x) (clean (cdr x) :key t)))
 231                ;; &ENVIRONMENT ENV and &WHOLE FORM is not interesting to the user.
 232                ((cons (member &environment &whole))
 233                 (clean (cddr x) :optional optional :key key))
 234                ((cons cons)
 235                 (cons
 236                  (cond (key (if (consp (caar x))
 237                                 (caaar x)
 238                                 (caar x)))
 239                        (optional (caar x))
 240                        (t (clean (car x))))
 241                  (clean (cdr x) :key key :optional optional)))
 242                (cons
 243                 (cons
 244                  (cond ((or key optional) (car x))
 245                        (t (clean (car x))))
 246                  (clean (cdr x) :key key :optional optional))))))
 247     (case (get-kind doc)
 248       ((package constant variable structure class condition nil)
 249        nil)
 250 ;;;       ((type)
 251 ;;;        ;; FIND-SYMBOL to avoid compilation errors on older SBCL versions:
 252 ;;;        (clean (funcall (find-symbol "INFO" :sb-int)
 253 ;;;                    :type
 254 ;;;                    :lambda-list
 255 ;;;                    (get-name doc))))
 256       (method
 257        (third (get-name doc)))
 258       (t
 259        (when (symbolp (get-name doc))
 260          (clean (function-arglist (get-name doc))))))))
 261
 262 (defun documentation< (x y)
 263   (let ((p1 (position (get-kind x) *ordered-documentation-kinds*))
 264         (p2 (position (get-kind y) *ordered-documentation-kinds*)))
 265     (cond ((and p1 p2 (/= p1 p2))
 266            (< p1 p2))
 267           ((and (or p1 p2) (not (and p1 p2)))
 268            (and p1 t))
 269           (t
 270            (string< (string (get-symbol x)) (string (get-symbol y)))))))
 271
 272 ;;;; main logic
 273
 274 (defun collect-gf-documentation (gf)
 275   "Collects method documentation for the generic function GF"
 276   (loop for method in (generic-function-methods gf)
 277         for doc = (documentation* method t)
 278         when doc
 279         collect doc))
 280
 281 (defun collect-name-documentation (name)
 282   (loop for type in *documentation-types*
 283         for doc = (documentation* name type)
 284         when doc
 285         collect doc))
 286
 287 (defun collect-symbol-documentation (symbol)
 288   "Collects all docs for a SYMBOL and (SETF SYMBOL), returns a list of
 289 the form DOC instances. See `*documentation-types*' for the possible
 290 values of doc-type."
 291   (nconc (collect-name-documentation symbol)
 292          (collect-name-documentation (list 'setf symbol))))
 293
 294 (defun collect-documentation (package &optional package-name)
 295   "Collects all documentation for all external symbols of the given
 296 package, as well as for the package itself."
 297   (let* ((*documentation-package* (find-package package))
 298          (*documentation-package-name*
 299           (or package-name (package-name *documentation-package*)))
 300          (docs nil))
 301     (check-type package package)
 302     (do-external-symbols (symbol package)
 303       (setf docs (nconc (collect-symbol-documentation symbol) docs)))
 304     (let ((doc (documentation* *documentation-package* t)))
 305       (when doc
 306         (push doc docs)))
 307     docs))