Permalink
Fetching contributors…
Cannot retrieve contributors at this time
186 lines (166 sloc) 6.23 KB
;;; doc.lisp --- extract blocky docs into orgmode format
;; Copyright (C) 2009-2011, 2012 David O'Toole
;; Author: David O'Toole dto@ioforms.org
;; Keywords: lisp, tools
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see ^http://www.gnu.org/licenses/.
(in-package :blocky)
(defun methodp (symbol)
(and (fboundp symbol)
(get 'symbol 'is-method)))
(defun document-extended-argument (entry stream)
(format stream "~A" entry))
(defun heading (level text stream)
(fresh-line stream)
(format stream "~A ~A"
(make-string level :initial-element (character "*"))
text)
(fresh-line stream))
(defun document-method (prototype method stream)
(let* ((symbol (intern (make-method-id prototype method)))
(doc (documentation symbol 'function)))
(when doc
(multiple-value-bind (arglist options prototype method)
(find-method-data prototype method)
(heading 2 (format nil "~A (method)" (make-non-keyword method))
stream)
(heading 3 "Arguments" stream)
(dolist (arg arglist)
(document-extended-argument arg stream)
(fresh-line stream))
(heading 3 "Documentation" stream)
(format stream "~A" doc)
(fresh-line stream)))))
(defun document-function (symbol stream)
(let ((doc (documentation symbol 'function)))
(when doc
(let ((type (cond
((macro-function symbol) 'macro)
((fboundp symbol) 'function))))
(heading 2 (format nil "~A (~A)" symbol (string-downcase (symbol-name type)))
stream)
(heading 3 "Arguments" stream)
(format stream "~S" (sb-introspect:function-lambda-list (fdefinition symbol)))
(heading 3 "Documentation" stream)
(format stream "~A" doc)
(fresh-line stream)))))
(defun document-variable (symbol stream)
(heading 2 (format nil "~A (variable)" symbol)
stream)
(heading 3 "Documentation" stream)
(format stream "~A" (documentation symbol 'variable))
(fresh-line stream))
(defun find-prototype-methods (prototype)
(let ((proto (find-object prototype))
(methods '()))
(labels ((extract (k v)
(when (and (symbolp v)
(fboundp v))
(push k methods))))
(maphash #'extract
(object-fields proto)))
(sort methods #'string<)))
(defun document-prototype (name stream)
(heading 1 (format nil "~A (prototype)" (subseq name (1+ (position (character ":") name))))
stream)
(let ((proto (gethash name *prototypes*)))
(when proto
(let* ((field-descriptors
(field-value :field-descriptors proto))
(parent-name (find-super-prototype-name proto))
(methods (find-prototype-methods proto)))
(when parent-name
(heading 3 (format nil "Parent name: ~A" parent-name) stream))
(let ((doc (field-value :documentation proto)))
(when (stringp doc)
(heading 2 "Documentation" stream)
(format stream "~A" doc)
(fresh-line stream)))
(when field-descriptors
(heading 2 "Fields" stream)
(dolist (d field-descriptors)
(fresh-line stream)
(destructuring-bind (name (&key documentation initform &allow-other-keys)) d
(when (and name documentation)
(format stream "*** ~A (field)" name)
(heading 4 "Documentation" stream)
(format stream "~A" documentation)
(fresh-line stream)
(when initform
(heading 4 "Initial value" stream)
(format stream "~S" initform))))))
(fresh-line stream)
;; methods
(message "Documenting ~S methods..." (length methods))
(dolist (m methods)
(document-method name m stream))
methods))))
(defun preamble-file-lines (preamble-file)
(with-open-file (file preamble-file
:direction :input
:if-does-not-exist nil)
(let* ((len (file-length file))
(string (make-string len)))
(read-sequence string file)
(split-string-on-lines string))))
;; (loop for line = (read-line file nil)
;; while line collect line)))
(defun document-package (package-name &key (stream t) preamble-file title)
(let ((package (find-package package-name))
symbols functions variables)
;; header
(when title
(format stream "#+TITLE: ~A" title)
(fresh-line stream))
(format stream "#+OPTIONS: toc:2 *:nil")
(fresh-line stream)
(do-external-symbols (symbol package)
(push symbol symbols))
;; remove method symbols and method defun symbols
(setf symbols
(sort
(remove-if #'(lambda (s)
(or (search "%" (symbol-name s))
(methodp s)))
symbols)
#'string<))
;; print preamble
(let ((preamble-lines
(when preamble-file
(preamble-file-lines preamble-file))))
(when preamble-file
(dolist (line preamble-lines)
(format stream "~A " line)
(fresh-line stream))))
;; document prototypes and their respective methods
(let (prototypes)
(loop for prototype being the hash-keys in *prototypes* do
(push prototype prototypes))
(setf prototypes
(mapcar #'(lambda (name)
(subseq name (1+ (position (character ":") name))))
prototypes))
(dolist (prototype (sort prototypes #'string<))
(let ((methods (document-prototype (concatenate 'string "BLOCKY:" prototype) stream)))
(dolist (method methods)
(setf symbols (remove (make-non-keyword method) symbols :test 'eq)))
)))
;; document syms
(heading 1 "Functions, Macros, and Variables" stream)
(dolist (sym symbols)
(if (fboundp sym)
(document-function sym stream)
(document-variable sym stream)))))
(defun document-package-to-file (package-name output-file &key preamble-file title)
(with-open-file (stream output-file :direction :output :if-exists :supersede)
(document-package package-name :title title :stream stream :preamble-file preamble-file)))
;; (document-package-to-file :blocky #P"/home/dto/ioweb/reference.org" :title "Blocky reference manual" :preamble-file #P"~/blocky/guide.org")
;;; doc.lisp ends here