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 &optional (downcase-p t))
  59   "Return 'string-designator' with characters in
  60   *texinfo-escaped-chars* escaped with #\@.  Optionally downcase
  61   the result."
  62   (let ((result (with-output-to-string (s)
  63        (loop for char across (string string-designator)
  64           when (find char *texinfo-escaped-chars*)
  65           do (write-char #\@ s)
  66           do (write-char char s)))))
  67     (if downcase-p (nstring-downcase result) result)))
  68
  69 (defvar *symbol-characters* "ABCDEFGHIJKLMNOPQRSTUVWXYZ*:-+"
  70   "List of characters that make up symbols in a docstring.")
  71
  72 (defvar *symbol-delimiters* " ,.!?")
  73
  74 (defun locate-symbols (line)
  75   "Return a list of index pairs of symbol-like parts of LINE."
  76   (do ((result nil)
  77        (begin nil)
  78        (maybe-begin t)
  79        (i 0 (1+ i)))
  80       ((= i (length line))
  81        (when begin (push (list begin i) result))
  82        (nreverse result))
  83     (cond
  84       ((and begin (find (char line i) *symbol-delimiters*))
  85        ;; symbol end; remember it if it's not "A" or "I"
  86        (when (or (> i (1+ begin)) (not (member (char line begin) '(#\A #\I))))
  87          (push (list begin i) result))
  88        (setf begin nil
  89              maybe-begin t))
  90       ((and begin (not (find (char line i) *symbol-characters*)))
  91        ;; Not a symbol: abort
  92        (setf begin nil))
  93       ((and maybe-begin (not begin) (find (char line i) *symbol-characters*))
  94        ;; potential symbol begin at this position
  95        (setf begin i
  96              maybe-begin nil))
  97       ((find (char line i) *symbol-delimiters*)
  98        ;; potential symbol begin after this position
  99        (setf maybe-begin t)))))
 100
 101 (defun all-symbols (list)
 102   (cond ((or (null list) (numberp list)) nil)
 103         ((atom list) (list list))
 104         (t (append (all-symbols (car list)) (all-symbols (cdr list))))))
 105
 106 (defun frob-docstring (docstring symbol-arglist)
 107   "Try to guess as much formatting for a raw docstring as possible."
 108   ;; Per-line processing is not necessary now, but it will be when we
 109   ;; attempt itemize / table auto-detection in docstrings
 110   (with-output-to-string (result)
 111     (let ((arglist-symbols (all-symbols symbol-arglist)))
 112       (with-input-from-string (s (texinfoify docstring nil))
 113         (loop for line = (read-line s nil nil)
 114            while line
 115            do (let ((last 0))
 116                 (dolist (symbol-index (locate-symbols line))
 117                   (write-string (subseq line last (first symbol-index)) result)
 118                   (let ((symbol-name (apply #'subseq line symbol-index)))
 119                     (format result (if (member symbol-name arglist-symbols
 120                                                :test #'string=)
 121                                        "@var{~A}"
 122                                        "@code{~A}")
 123                             (string-downcase symbol-name)))
 124                   (setf last (second symbol-index)))
 125                 (write-line (subseq line last) result)))))))
 126
 127 ;;; Begin, rest and end of definition.
 128
 129 (defun argument-list (fname)
 130   (sb-introspect:function-arglist fname))
 131
 132 (defvar *character-replacements*
 133   '((#\* . "star") (#\/ . "slash") (#\+ . "plus"))
 134   "Characters and their replacement names that `alphanumize'
 135   uses.  If the replacements contain any of the chars they're
 136   supposed to replace, you deserve to lose.")
 137
 138 (defvar *characters-to-drop* '(#\\ #\` #\')
 139   "Characters that should be removed by `alphanumize'.")
 140
 141
 142 (defun alphanumize (symbol)
 143   "Construct a string without characters like *`' that will
 144   f-star-ck up filename handling.  See `*character-replacements*'
 145   and `*characters-to-drop*' for customization."
 146   (let ((name (remove-if #'(lambda (x) (member x *characters-to-drop*))
 147                          (string symbol)))
 148         (chars-to-replace (mapcar #'car *character-replacements*)))
 149     (flet ((replacement-delimiter (index)
 150              (cond ((or (< index 0) (>= index (length name))) "")
 151                    ((alphanumericp (char name index)) "-")
 152                    (t ""))))
 153       (loop for index = (position-if #'(lambda (x) (member x chars-to-replace))
 154                                      name)
 155          while index
 156          do (setf name (concatenate 'string (subseq name 0 index)
 157                                     (replacement-delimiter (1- index))
 158                                     (cdr (assoc (aref name index)
 159                                                 *character-replacements*))
 160                                     (replacement-delimiter (1+ index))
 161                                     (subseq name (1+ index))))))
 162     name))
 163
 164 (defun unique-name (symbol package kind)
 165   (nstring-downcase
 166    (format nil "~A-~A-~A"
 167            (ecase kind
 168              (compiler-macro "compiler-macro")
 169              (function (cond
 170                          ((macro-function symbol) "macro")
 171                          ((special-operator-p symbol) "special-operator")
 172                          (t "fun")))
 173              (method-combination "method-combination")
 174              (package "package")
 175              (setf "setf-expander")
 176              (structure "struct")
 177              (type (let ((class (find-class symbol nil)))
 178                      (etypecase class
 179                        (structure-class "struct")
 180                        (standard-class "class")
 181                        (sb-pcl::condition-class "condition")
 182                        ((or built-in-class null) "type"))))
 183              (variable (if (constantp symbol)
 184                            "constant"
 185                            "var")))
 186            (package-name package)
 187            (alphanumize symbol))))
 188
 189 (defun def-begin (symbol kind)
 190   (ecase kind
 191     (compiler-macro "@deffn {Compiler Macro}")
 192     (function (cond
 193                 ((macro-function symbol) "@deffn Macro")
 194                 ((special-operator-p symbol) "@deffn {Special Operator}")
 195                 (t "@deffn Function")))
 196     (method-combination "@deffn {Method Combination}")
 197     (package "@defvr Package")
 198     (setf "@deffn {Setf Expander}")
 199     (structure "@deftp Structure")
 200     (type (let ((class (find-class symbol nil)))
 201             (etypecase class
 202               (structure-class "@deftp Structure")
 203               (standard-class "@deftp Class")
 204               (sb-pcl::condition-class "@deftp Condition")
 205               ((or built-in-class null) "@deftp Type"))))
 206     (variable (if (constantp symbol)
 207                   "@defvr Constant"
 208                   "@defvr Variable"))))
 209
 210 (defun def-index (symbol kind)
 211   (case kind
 212     ((compiler-macro function method-combination)
 213      (format nil "@findex ~A" (texinfoify symbol)))
 214     ((structure type)
 215      (format nil "@tindex ~A" (texinfoify symbol)))
 216     (variable
 217      (format nil "@vindex ~A" (texinfoify symbol)))))
 218
 219 (defparameter *arglist-keywords*
 220   '(&allow-other-keys &aux &body &environment &key &optional &rest &whole))
 221
 222 (defun texinfoify-arglist-part (part)
 223   (with-output-to-string (s)
 224     (etypecase part
 225       (string (prin1 (texinfoify part nil) s))
 226       (number (prin1 part s))
 227       (symbol
 228        (if (member part *arglist-keywords*)
 229            (princ (texinfoify part) s)
 230            (format s "@var{~A}" (texinfoify part))))
 231       (list
 232        (format s "(~{~A~^ ~})" (mapcar #'texinfoify-arglist-part part))))))
 233
 234 (defun def-arglist (symbol kind)
 235   (case kind
 236     (function
 237      (format nil "~{~A~^ ~}"
 238              (mapcar #'texinfoify-arglist-part (argument-list symbol))))))
 239
 240 (defun def-end (symbol kind)
 241   (declare (ignore symbol))
 242   (ecase kind
 243     ((compiler-macro function method-combination setf) "@end deffn")
 244     ((package variable) "@end defvr")
 245     ((structure type) "@end deftp")))
 246
 247 (defun make-info-file (package &optional filename)
 248   "Create a file containing all available documentation for the
 249   exported symbols of `package' in Texinfo format.  If `filename'
 250   is not supplied, a file \"<packagename>.texinfo\" is generated.
 251
 252   The definitions can be referenced using Texinfo statements like
 253   @ref{<doc-type>_<packagename>_<symbol-name>.texinfo}.  Texinfo
 254   syntax-significant characters are escaped in symbol names, but
 255   if a docstring contains invalid Texinfo markup, you lose."
 256   (let* ((package (find-package package))
 257          (filename (or filename (make-pathname
 258                                  :name (string-downcase (package-name package))
 259                                  :type "texinfo")))
 260          (docs (sort (collect-documentation package) #'string< :key #'first)))
 261     (with-open-file (out filename :direction :output
 262                          :if-does-not-exist :create :if-exists :supersede)
 263       (loop for (symbol kind docstring) in docs
 264            do (format out "~&@anchor{~A}~%~A ~A:~A~@[ ~A~]~%~A~&~A~%~A~%~%"
 265                       (unique-name symbol package kind)
 266                       (def-begin symbol kind)
 267                       (texinfoify (package-name package))
 268                       (texinfoify symbol)
 269                       (def-arglist symbol kind)
 270                       (def-index symbol kind)
 271                       (frob-docstring docstring (argument-list symbol))
 272                       (def-end symbol kind))))
 273     filename))
 274
 275 (defun docstrings-to-texinfo (directory &rest packages)
 276   "Create files in `directory' containing Texinfo markup of all
 277   docstrings of each exported symbol in `packages'.  `directory'
 278   is created if necessary.  If you supply a namestring that
 279   doesn't end in a slash, you lose.  The generated files are of
 280   the form \"<doc-type>_<packagename>_<symbol-name>.texinfo\" and
 281   can be included via @include statements.  Texinfo
 282   syntax-significant characters are escaped in symbol names, but
 283   if a docstring contains invalid Texinfo markup, you lose."
 284   (let ((directory (merge-pathnames (pathname directory))))
 285     (ensure-directories-exist directory)
 286     (dolist (package packages)
 287       (loop
 288          with docs = (collect-documentation (find-package package))
 289          for (symbol kind docstring) in docs
 290          for doc-identifier = (unique-name symbol package kind)
 291          do (with-open-file (out
 292                              (merge-pathnames
 293                               (make-pathname :name doc-identifier :type "texinfo")
 294                               directory)
 295                              :direction :output
 296                              :if-does-not-exist :create :if-exists :supersede)
 297               (format out "~&@anchor{~A}~%~A ~A:~A~@[ ~A~]~%~A~&~A~%~A~%~%"
 298                       (unique-name symbol package kind)
 299                       (def-begin symbol kind)
 300                       (texinfoify (package-name package))
 301                       (texinfoify symbol)
 302                       (def-arglist symbol kind)
 303                       (def-index symbol kind)
 304                       (frob-docstring docstring (ignore-errors (argument-list symbol)))
 305                       (def-end symbol kind)))))
 306     directory))