doc/manual/docstrings.lisp

   1 ;;;; -*- lisp -*-
   2
   3 ;;;; (c) 2004 Rudi Schlatte <rudi@constantly.at>
   4 ;;;; Use it as you wish, send changes back to me if you like.
   5
   6 #+sbcl
   7 (eval-when (:compile-toplevel :load-toplevel :execute)
   8   (require 'sb-introspect))
   9
  10 (defparameter *documentation-types*
  11   '(compiler-macro
  12     function
  13     method-combination
  14     setf
  15     ;;structure  ; also handled by `type'
  16     type
  17     variable)
  18   "A list of symbols accepted as second argument of `documentation'")
  19
  20 ;;; Collecting info from package
  21
  22 (defun documentation-for-symbol (symbol)
  23   "Collects all doc for a symbol, returns a list of the
  24   form (symbol doc-type docstring).  See `*documentation-types*'
  25   for the possible values of doc-type."
  26   (loop for kind in *documentation-types*
  27        for doc = (documentation symbol kind)
  28        when doc
  29        collect (list symbol kind doc)))
  30
  31 (defun collect-documentation (package)
  32   "Collects all documentation for all external symbols of the
  33   given package, as well as for the package itself."
  34   (let* ((package (find-package package))
  35          (package-doc (documentation package t))
  36          (result nil))
  37     (check-type package package)
  38     (do-external-symbols (symbol package)
  39       (let ((docs (documentation-for-symbol symbol)))
  40         (when docs (setf result (nconc docs result)))))
  41     (when package-doc
  42       (setf result (nconc (list (list (intern (package-name package) :keyword)
  43                                       'package package-doc)) result)))
  44     result))
  45
  46 ;;; Helpers for texinfo output
  47
  48 (defvar *texinfo-escaped-chars* "@{}"
  49   "Characters that must be escaped with #\@ for Texinfo.")
  50
  51 (defun texinfoify (string-designator)
  52   "Return 'string-designator' with characters in
  53   *texinfo-escaped-chars* escaped with #\@"
  54   (let ((name (string string-designator)))
  55     (nstring-downcase
  56      (with-output-to-string (s)
  57        (loop for char across name
  58           when (find char *texinfo-escaped-chars*)
  59           do (write-char #\@ s)
  60           do (write-char char s))))))
  61
  62 ;;; Begin, rest and end of definition.
  63
  64 (defun argument-list (fname)
  65   (sb-introspect:function-arglist fname))
  66
  67 (defvar *character-replacements*
  68   '((#\* . "star") (#\/ . "slash") (#\+ . "plus"))
  69   "Characters and their replacement names that `alphanumize'
  70   uses.  If the replacements contain any of the chars they're
  71   supposed to replace, you deserve to lose.")
  72
  73 (defvar *characters-to-drop* '(#\\ #\` #\')
  74   "Characters that should be removed by `alphanumize'.")
  75
  76
  77 (defun alphanumize (symbol)
  78   "Construct a string without characters like *`' that will
  79   f-star-ck up filename handling.  See `*character-replacements*'
  80   and `*characters-to-drop*' for customization."
  81   (let ((name (remove-if #'(lambda (x) (member x *characters-to-drop*))
  82                          (string symbol)))
  83         (chars-to-replace (mapcar #'car *character-replacements*)))
  84     (flet ((replacement-delimiter (index)
  85              (cond ((or (< index 0) (>= index (length name))) "")
  86                    ((alphanumericp (char name index)) "-")
  87                    (t ""))))
  88       (loop for index = (position-if #'(lambda (x) (member x chars-to-replace))
  89                                      name)
  90          while index
  91          do (setf name (concatenate 'string (subseq name 0 index)
  92                                     (replacement-delimiter (1- index))
  93                                     (cdr (assoc (aref name index)
  94                                                 *character-replacements*))
  95                                     (replacement-delimiter (1+ index))
  96                                     (subseq name (1+ index))))))
  97     name))
  98
  99 (defun unique-name (symbol package kind)
 100   (nstring-downcase
 101    (format nil "~A-~A-~A"
 102            (ecase kind
 103              (compiler-macro "compiler-macro")
 104              (function (cond
 105                          ((macro-function symbol) "macro")
 106                          ((special-operator-p symbol) "special-operator")
 107                          (t "fun")))
 108              (method-combination "method-combination")
 109              (package "package")
 110              (setf "setf-expander")
 111              (structure "struct")
 112              (type (let ((class (find-class symbol)))
 113                      (etypecase class
 114                        (structure-class "struct")
 115                        (standard-class "class")
 116                        (sb-pcl::condition-class "condition")
 117                        ((or built-in-class null) "type"))))
 118              (variable (if (constantp symbol)
 119                            "constant"
 120                            "var")))
 121            (package-name package)
 122            (alphanumize symbol))))
 123
 124 (defun def-begin (symbol kind)
 125   (ecase kind
 126     (compiler-macro "@deffn {Compiler Macro}")
 127     (function (cond
 128                 ((macro-function symbol) "@defmac")
 129                 ((special-operator-p symbol) "@defspec")
 130                 (t "@defun")))
 131     (method-combination "@deffn {Method Combination}")
 132     (package "@deffn Package")
 133     (setf "@deffn {Setf Expander}")
 134     (structure "@deftp Structure")
 135     (type (let ((class (find-class symbol)))
 136             (etypecase class
 137               (structure-class "@deftp Structure")
 138               (standard-class "@deftp Class")
 139               (sb-pcl::condition-class "@deftp Condition")
 140               ((or built-in-class null) "@deftp Type"))))
 141     (variable (if (constantp symbol)
 142                   "@defvr Constant"
 143                   "@defvar"))))
 144
 145 (defparameter *arglist-keywords*
 146   '(&allow-other-keys &aux &body &environment &key &optional &rest &whole))
 147
 148 (defun texinfoify-arglist-part (part)
 149   (with-output-to-string (s)
 150     (etypecase part
 151       (string (prin1 (texinfoify part) s))
 152       (number (prin1 part s))
 153       (symbol
 154        (if (member part *arglist-keywords*)
 155            (princ (texinfoify part) s)
 156            (format s "@var{~A}" (texinfoify part))))
 157       (list
 158        (format s "(~{~A~^ ~})" (mapcar #'texinfoify-arglist-part part))))))
 159
 160 (defun def-rest (symbol kind)
 161   (case kind
 162     (function
 163      (format nil "~{~A~^ ~}" (mapcar #'texinfoify-arglist-part
 164                                      (argument-list symbol))))))
 165
 166 (defun def-end (symbol kind)
 167   (ecase kind
 168     (compiler-macro "@end deffn")
 169     (function (cond
 170                 ((macro-function symbol) "@end defmac")
 171                 ((special-operator-p symbol) "@end defspec")
 172                 (t "@end defun")))
 173     (method-combination "@end deffn")
 174     (package "@end deffn")
 175     (setf "@end deffn")
 176     (type "@end deftp")
 177     (variable (if (constantp symbol)
 178                   "@end defvr"
 179                   "@defvar"))))
 180
 181 (defun make-info-file (package &optional filename)
 182   "Create a file containing all available documentation for the
 183   exported symbols of `package' in Texinfo format.  If `filename'
 184   is not supplied, a file \"<packagename>.texinfo\" is generated.
 185
 186   The definitions can be referenced using Texinfo statements like
 187   @ref{<doc-type>_<packagename>_<symbol-name>.texinfo}.  Texinfo
 188   syntax-significant characters are escaped in symbol names, but
 189   if a docstring contains invalid Texinfo markup, you lose."
 190   (let* ((package (find-package package))
 191          (filename (or filename (make-pathname
 192                                  :name (string-downcase (package-name package))
 193                                  :type "texinfo")))
 194          (docs (sort (collect-documentation package) #'string< :key #'first)))
 195     (with-open-file (out filename :direction :output
 196                          :if-does-not-exist :create :if-exists :supersede)
 197       (loop for (symbol kind docstring) in docs
 198            do (format out "~&@anchor{~A}~%~A ~A~@[ ~A~]~%~A~%~A~%~%"
 199                       (unique-name symbol package kind)
 200                       (def-begin symbol kind)
 201                       (texinfoify symbol)
 202                       (def-rest symbol kind)
 203                       docstring
 204                       (def-end symbol kind))))
 205     filename))
 206
 207 (defun docstrings-to-texinfo (directory &rest packages)
 208   "Create files in `directory' containing Texinfo markup of all
 209   docstrings of each exported symbol in `packages'.  `directory'
 210   is created if necessary.  If you supply a namestring that
 211   doesn't end in a slash, you lose.  The generated files are of
 212   the form \"<doc-type>_<packagename>_<symbol-name>.texinfo\" and
 213   can be included via @include statements.  Texinfo
 214   syntax-significant characters are escaped in symbol names, but
 215   if a docstring contains invalid Texinfo markup, you lose."
 216   (let ((directory (merge-pathnames (pathname directory))))
 217     (ensure-directories-exist directory)
 218     (dolist (package packages)
 219       (loop
 220          with docs = (collect-documentation (find-package package))
 221          for (symbol kind docstring) in docs
 222          for doc-identifier = (unique-name symbol package kind)
 223          do (with-open-file (out
 224                              (merge-pathnames
 225                               (make-pathname :name doc-identifier :type "texinfo")
 226                               directory)
 227                              :direction :output
 228                              :if-does-not-exist :create :if-exists :supersede)
 229               (format out "~&@anchor{~A}~%~A ~A~@[ ~A~]~%~A~%~A~%~%"
 230                       (unique-name symbol package kind)
 231                       (def-begin symbol kind)
 232                       (texinfoify symbol)
 233                       (def-rest symbol kind)
 234                       docstring
 235                       (def-end symbol kind)))))
 236     directory))