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 ;;;; frontend selection
 130
 131 (defvar *default-docstring-parser*
 132   'parse-docstrings.sbcl:parse-docstring)
 133
 134 (defgeneric docstring-parser-for (x))
 135
 136 (defmethod docstring-parser-for ((x package))
 137   (let ((configuration
 138          (find-symbol "DOCSTRING-PARSER" x)))
 139     (or (and configuration
 140              (funcall configuration))
 141         *default-docstring-parser*)))
 142
 143 (defmethod docstring-parser-for ((x symbol))
 144   (docstring-parser-for (symbol-package x)))
 145
 146
 147 ;;;; methods related to the documentation* class
 148
 149 (defun get-symbol (doc)
 150   (let ((name (get-name doc)))
 151     (cond ((symbolp name)
 152            name)
 153           ((and (consp name) (eq 'setf (car name)))
 154            (second name))
 155           (t
 156            (error "Don't know which symbol to sort by: ~S" name)))))
 157
 158 (defmethod print-object ((documentation documentation*) stream)
 159   (print-unreadable-object (documentation stream :type t)
 160     (princ (list (get-kind documentation) (get-name documentation)) stream)))
 161
 162 (defgeneric make-documentation (x doc-type string))
 163
 164 (defmethod make-documentation :around (x doc-type string)
 165   (let ((doc (call-next-method)))
 166     (setf (get-content doc)
 167           (funcall (docstring-parser-for (if (packagep x) x (name x))) string))
 168     doc))
 169
 170 (defmethod make-documentation ((x package) doc-type string)
 171   (declare (ignore doc-type string))
 172   (make-instance 'documentation*
 173                  :name (name x)
 174                  :kind 'package))
 175
 176 (defmethod make-documentation (x (doc-type (eql 'function)) string)
 177   (declare (ignore doc-type string))
 178   (let* ((fdef (and (fboundp x) (fdefinition x)))
 179          (name x)
 180          (kind (cond ((and (symbolp x) (special-operator-p x))
 181                       'special-operator)
 182                      ((and (symbolp x) (macro-function x))
 183                       'macro)
 184                      ((typep fdef 'generic-function)
 185                       (assert (or (symbolp name) (setf-name-p name)))
 186                       'generic-function)
 187                      (fdef
 188                       (assert (or (symbolp name) (setf-name-p name)))
 189                       'function)))
 190          (children (when (eq kind 'generic-function)
 191                      (collect-gf-documentation fdef))))
 192     (make-instance 'documentation*
 193                    :name (name x)
 194                    :kind kind
 195                    :children children)))
 196
 197 (defmethod make-documentation ((x method) doc-type string)
 198   (declare (ignore doc-type string))
 199   (make-instance 'documentation*
 200                  :name (name x)
 201                  :kind 'method))
 202
 203 (defmethod make-documentation (x (doc-type (eql 'type)) string)
 204   (declare (ignore string))
 205   (make-instance 'documentation*
 206                  :name (name x)
 207                  :kind (etypecase (find-class x nil)
 208                          (structure-class 'structure)
 209                          (standard-class 'class)
 210                          (sb-pcl::condition-class 'condition)
 211                          ((or built-in-class null) 'type))))
 212
 213 (defmethod make-documentation (x (doc-type (eql 'variable)) string)
 214   (declare (ignore string))
 215   (make-instance 'documentation*
 216                  :name (name x)
 217                  :kind (if (constantp x)
 218                            'constant
 219                            'variable)))
 220
 221 (defmethod make-documentation (x (doc-type (eql 'setf)) string)
 222   (declare (ignore doc-type string))
 223   (make-instance 'documentation*
 224                  :name (name x)
 225                  :kind 'setf-expander))
 226
 227 (defmethod make-documentation (x doc-type string)
 228   (declare (ignore string))
 229   (make-instance 'documentation*
 230                  :name (name x)
 231                  :kind doc-type))
 232
 233 (defun documentation* (x doc-type)
 234   "Returns a DOCUMENTATION instance for X and DOC-TYPE, or NIL if
 235 there is no corresponding docstring."
 236   (let ((docstring (docstring x doc-type)))
 237     (when (plusp (length docstring))
 238       (make-documentation x doc-type docstring))))
 239
 240 (defun lambda-list (doc)
 241   ;; KLUDGE: Eugh.
 242   ;;
 243   ;; believe it or not, the above comment was written before CSR came along
 244   ;; and obfuscated this. (2005-07-04)
 245   (labels ((clean (x &key optional key)
 246              (typecase x
 247                (atom x)
 248                ((cons (member &optional))
 249                 (cons (car x) (clean (cdr x) :optional t)))
 250                ((cons (member &key))
 251                 (cons (car x) (clean (cdr x) :key t)))
 252                ;; &ENVIRONMENT ENV and &WHOLE FORM is not interesting to the user.
 253                ((cons (member &environment &whole))
 254                 (clean (cddr x) :optional optional :key key))
 255                ((cons cons)
 256                 (cons
 257                  (cond (key (if (consp (caar x))
 258                                 (caaar x)
 259                                 (caar x)))
 260                        (optional (caar x))
 261                        (t (clean (car x))))
 262                  (clean (cdr x) :key key :optional optional)))
 263                (cons
 264                 (cons
 265                  (cond ((or key optional) (car x))
 266                        (t (clean (car x))))
 267                  (clean (cdr x) :key key :optional optional))))))
 268     (case (get-kind doc)
 269       ((package constant variable structure class condition nil)
 270        nil)
 271 ;;;       ((type)
 272 ;;;        ;; FIND-SYMBOL to avoid compilation errors on older SBCL versions:
 273 ;;;        (clean (funcall (find-symbol "INFO" :sb-int)
 274 ;;;                    :type
 275 ;;;                    :lambda-list
 276 ;;;                    (get-name doc))))
 277       (method
 278        (third (get-name doc)))
 279       (t
 280        (when (symbolp (get-name doc))
 281          (clean (function-arglist (get-name doc))))))))
 282
 283 (defun documentation< (x y)
 284   (let ((p1 (position (get-kind x) *ordered-documentation-kinds*))
 285         (p2 (position (get-kind y) *ordered-documentation-kinds*)))
 286     (cond ((and p1 p2 (/= p1 p2))
 287            (< p1 p2))
 288           ((and (or p1 p2) (not (and p1 p2)))
 289            (and p1 t))
 290           (t
 291            (string< (string (get-symbol x)) (string (get-symbol y)))))))
 292
 293 ;;;; main logic
 294
 295 (defun collect-gf-documentation (gf)
 296   "Collects method documentation for the generic function GF"
 297   (loop for method in (generic-function-methods gf)
 298         for doc = (documentation* method t)
 299         when doc
 300         collect doc))
 301
 302 (defun collect-name-documentation (name)
 303   (loop for type in *documentation-types*
 304         for doc = (documentation* name type)
 305         when doc
 306         collect doc))
 307
 308 (defun collect-symbol-documentation (symbol)
 309   "Collects all docs for a SYMBOL and (SETF SYMBOL), returns a list of
 310 the form DOC instances. See `*documentation-types*' for the possible
 311 values of doc-type."
 312   (nconc (collect-name-documentation symbol)
 313          (collect-name-documentation (list 'setf symbol))))
 314
 315 (defun collect-documentation (package &optional package-name)
 316   "Collects all documentation for all external symbols of the given
 317 package, as well as for the package itself."
 318   (let* ((*documentation-package* (find-package package))
 319          (*documentation-package-name*
 320           (or package-name (package-name *documentation-package*)))
 321          (docs nil))
 322     (check-type package package)
 323     (do-external-symbols (symbol package)
 324       (setf docs (nconc (collect-symbol-documentation symbol) docs)))
 325     (let ((doc (documentation* *documentation-package* t)))
 326       (when doc
 327         (push doc docs)))
 328     docs))