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