doc/manual/docstrings.lisp

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