--- /dev/null
+;;;; -*- lisp -*-
+
+;;;; (c) 2004 Rudi Schlatte <rudi@constantly.at>
+;;;; Use it as you wish, send changes back to me if you like.
+
+#+sbcl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require 'sb-introspect)
+ )
+
+(defparameter *documentation-types*
+ '(compiler-macro
+ function
+ method-combination
+ setf
+ ;;structure ; also handled by `type'
+ type
+ variable)
+ "A list of symbols accepted as second argument of `documentation'")
+
+;;; Collecting info from package
+
+(defun documentation-for-symbol (symbol)
+ "Collects all doc for a symbol, returns a list of the
+ form (symbol doc-type docstring). See `*documentation-types*'
+ for the possible values of doc-type."
+ (loop for kind in *documentation-types*
+ for doc = (documentation symbol kind)
+ when doc
+ collect (list symbol kind doc)))
+
+(defun collect-documentation (package)
+ "Collects all documentation for all external symbols of the
+ given package, as well as for the package itself."
+ (let* ((package (find-package package))
+ (package-doc (documentation package t))
+ (result nil))
+ (do-external-symbols (symbol package)
+ (let ((docs (documentation-for-symbol symbol)))
+ (when docs (setf result (nconc docs result)))))
+ (when package-doc
+ (setf result (nconc (list (list (intern (package-name package) :keyword)
+ 'package package-doc)) result)))))
+
+;;; Helpers for texinfo output
+
+(defvar *texinfo-escaped-chars* "@{}"
+ "Characters that must be escaped with #\@ for Texinfo.")
+
+(defun texinfoify (string-designator)
+ "Return 'string-designator' with characters in
+ *texinfo-escaped-chars* escaped with #\@"
+ (let ((name (string string-designator)))
+ (nstring-downcase
+ (with-output-to-string (s)
+ (loop for char across name
+ when (find char *texinfo-escaped-chars*)
+ do (write-char #\@ s)
+ do (write-char char s))))))
+
+;;; Begin, rest and end of definition.
+
+(defun argument-list (fname)
+ (prog1
+ ;; arglist accessors looked up in slime; FIXME: can we depend on
+ ;; swank instead? Some of the arglist accessors (not found
+ ;; here) are hairy ...
+ #+clisp (ext:arglist fname)
+ #+sbcl (sb-introspect:function-arglist fname)
+ #+openmcl (ccl:arglist fname)
+ '(arglist not supported in this implementation)
+ ))
+
+(defvar *character-replacements*
+ '((#\* . "star") (#\/ . "slash"))
+ "Characters and their replacement names that `alphanumize'
+ uses. If the replacements contain any of the chars they're
+ supposed to replace, you deserve to lose.")
+
+(defvar *characters-to-drop* '(#\\ #\` #\')
+ "Characters that should be removed by `alphanumize'.")
+
+
+(defun alphanumize (symbol)
+ "Construct a string without characters like *`' that will
+ f-star-ck up filename handling. See `*character-replacements*'
+ and `*characters-to-drop*' for customization."
+ (let ((name (remove-if #'(lambda (x) (member x *characters-to-drop*))
+ (string symbol)))
+ (chars-to-replace (mapcar #'car *character-replacements*)))
+ (flet ((replacement-delimiter (index)
+ (cond ((or (< index 0) (>= index (length name))) "")
+ ((alphanumericp (char name index)) "-")
+ (t ""))))
+ (loop for index = (position-if #'(lambda (x) (member x chars-to-replace))
+ name)
+ while index
+ do (setf name (concatenate 'string (subseq name 0 index)
+ (replacement-delimiter (1- index))
+ (cdr (assoc (aref name index)
+ *character-replacements*))
+ (replacement-delimiter (1+ index))
+ (subseq name (1+ index))))))
+ name))
+
+(defun unique-name (symbol kind)
+ (nstring-downcase
+ (format nil "~A-~A-~A"
+ (ecase kind
+ (compiler-macro "compiler-macro")
+ (function (if (macro-function symbol)
+ "macro"
+ "fun"))
+ (method-combination "method-combination")
+ (package "package")
+ (setf "setf-expander")
+ (structure "struct")
+ (type (if (find-class symbol)
+ (if (documentation symbol 'structure) ; cheesy structness check
+ "struct"
+ "class")
+ "type"))
+ (variable (if (constantp symbol)
+ "constant"
+ "var")))
+ (package-name (symbol-package symbol))
+ (alphanumize symbol)
+ )))
+
+(defun def-begin (symbol kind)
+ (ecase kind
+ (compiler-macro "@deffn {Compiler Macro}")
+ (function (if (macro-function symbol)
+ "@defmac"
+ "@defun"))
+ (method-combination "@deffn {Method Combination}")
+ (package "@deffn Package")
+ (setf "@deffn {Setf Expander}")
+ (structure "@deftp Structure")
+ (type (if (find-class symbol)
+ (if (documentation symbol 'structure) ; cheesy structness check
+ "@deftp Structure"
+ "@deftp Class")
+ "@deftp Type"))
+ (variable (if (constantp symbol)
+ "@defvr Constant"
+ "@defvar"))))
+
+(defparameter *arglist-keywords*
+ '(&allow-other-keys &aux &body &environment &key &optional &rest &whole))
+
+(defun texinfoify-arglist-part (part)
+ (with-output-to-string (s)
+ (etypecase part
+ (string (prin1 (texinfoify part) s))
+ (number (prin1 part s))
+ (symbol
+ (if (member part *arglist-keywords*)
+ (princ (texinfoify part) s)
+ (format s "@var{~A}" (texinfoify part))))
+ (list
+ (format s "(~{~A~^ ~})" (mapcar #'texinfoify-arglist-part part))))))
+
+(defun def-rest (symbol kind)
+ (case kind
+ (function
+ (format nil "~{~A~^ ~}" (mapcar #'texinfoify-arglist-part
+ (argument-list symbol))))))
+
+(defun def-end (symbol kind)
+ (ecase kind
+ (compiler-macro "@end deffn")
+ (function (if (macro-function symbol)
+ "@end defmac"
+ "@end defun"))
+ (method-combination "@end deffn")
+ (package "@end deffn")
+ (setf "@end deffn")
+ ;;(structure "@end deftp") ; caught by `type'
+ (type (if (find-class symbol)
+ (if (documentation symbol 'structure) ; cheesy structness check
+ "@end deftp"
+ "@end deftp")
+ "@end deftp"))
+ (variable (if (constantp symbol)
+ "@end defvr"
+ "@defvar"))))
+
+(defun make-info-file (package &optional filename)
+ "Create a file containing all available documentation for the
+ exported symbols of `package' in Texinfo format. If `filename'
+ is not supplied, a file \"<packagename>.texinfo\" is generated.
+
+ The definitions can be referenced using Texinfo statements like
+ @ref{<doc-type>_<packagename>_<symbol-name>.texinfo}. Texinfo
+ syntax-significant characters are escaped in symbol names, but
+ if a docstring contains invalid Texinfo markup, you lose."
+ (let* ((package (find-package package))
+ (filename (or filename (make-pathname
+ :name (string-downcase (package-name package))
+ :type "texinfo")))
+ (docs (sort (collect-documentation package) #'string< :key #'first)))
+ (with-open-file (out filename :direction :output
+ :if-does-not-exist :create :if-exists :supersede)
+ (loop for (symbol kind docstring) in docs
+ do (format out "~&@anchor{~A}~%~A ~A~@[ ~A~]~%~A~%~A~%~%"
+ (unique-name symbol kind)
+ (def-begin symbol kind)
+ (texinfoify symbol)
+ (def-rest symbol kind)
+ docstring
+ (def-end symbol kind))))
+ filename))
+
+(defun docstrings-to-texinfo (directory &rest packages)
+ "Create files in `directory' containing Texinfo markup of all
+ docstrings of each exported symbol in `packages'. `directory'
+ is created if necessary. If you supply a namestring that
+ doesn't end in a slash, you lose. The generated files are of
+ the form \"<doc-type>_<packagename>_<symbol-name>.texinfo\" and
+ can be included via @include statements. Texinfo
+ syntax-significant characters are escaped in symbol names, but
+ if a docstring contains invalid Texinfo markup, you lose."
+ (let ((directory (merge-pathnames (pathname directory))))
+ (ensure-directories-exist directory)
+ (dolist (package packages)
+ (loop
+ with docs = (collect-documentation (find-package package))
+ for (symbol kind docstring) in docs
+ for doc-identifier = (unique-name symbol kind)
+ do (with-open-file (out
+ (merge-pathnames
+ (make-pathname :name doc-identifier :type "texinfo")
+ directory)
+ :direction :output
+ :if-does-not-exist :create :if-exists :supersede)
+ (format out "~&@anchor{~A}~%~A ~A~@[ ~A~]~%~A~%~A~%~%"
+ (unique-name symbol kind)
+ (def-begin symbol kind)
+ (texinfoify symbol)
+ (def-rest symbol kind)
+ docstring
+ (def-end symbol kind)))))
+ directory))
projects / sbcl.git / commitdiff